home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / Wood / persistent-heap.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  114.9 KB  |  2,731 lines  |  [TEXT/CCL2]
  1. ;;;-*- Mode: Lisp; Package: (WOOD) -*-
  2.  
  3. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  4. ;;
  5. ;; persistent-heap.lisp
  6. ;; Code to maintain a Lisp heap in a file.
  7. ;;
  8. ;; Copyright © 1992 Apple Computer, Inc. All rights reserved.
  9. ;; Permission is given to use, copy, and modify this software provided
  10. ;; that this copyright notice is attached to all derivative works.
  11. ;; This software is provided "as is". Apple makes no warranty or
  12. ;; representation, either express or implied, with respect to this software,
  13. ;; its quality, accuracy, merchantability, or fitness for a particular
  14. ;; purpose.
  15. ;;
  16.  
  17. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  18. ;;
  19. ;; Modification History
  20. ;;
  21. ;; -------------- 0.5
  22. ;; 07/27/92 bill  p-clrhash, p-maphash
  23. ;; 06/23/92 bill  (open-pheap name :if-exists :supersede) now works
  24. ;; 06/04/92 bill  save/restore functions
  25. ;; 06/23/92 bill  save/restore CLOS instances -> persistent-clos.lisp
  26. ;; -------------- 0.1
  27. ;;
  28.  
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  30. ;;
  31. ;; To do.
  32. ;;
  33. ;; Hook for writing/reading macptr's
  34. ;;
  35. ;; Make abort in the middle of load or store clear the cache appropriately.
  36. ;;
  37. ;; p-maphash, p-map-btree
  38. ;;
  39. ;; persistent-stream
  40. ;;
  41. ;; Think about floats. The current implementation does not allow
  42. ;; for distinguishing floats and conses when walking memory.
  43. ;; 1) A float is a 16-byte vector. Free up the tag
  44. ;; 2) Cons floats in a special area.
  45. ;; 3) Don't worry about being able to walk memory.
  46.  
  47. (defpackage :wood)
  48. (in-package :wood)
  49.  
  50. (export '(create-pheap open-pheap close-pheap with-open-pheap
  51.           root-object p-load p-store
  52.           ))
  53.  
  54. (eval-when (:compile-toplevel :execute)
  55.   (require :woodequ)
  56.   (require :lispequ))
  57.  
  58. (defclass pheap ()
  59.   ((disk-cache :accessor pheap-disk-cache :initarg :disk-cache)
  60.    (consing-area :accessor pheap-consing-area :initarg :consing-area)
  61.    (pptr-hash :accessor pptr-hash
  62.               :initform (make-hash-table :weak :value :test 'eql))
  63.    (wrapper-hash :accessor wrapper-hash
  64.                  :initform (make-hash-table :weak :key :test 'eq))
  65.    (pheap->mem-hash :accessor pheap->mem-hash
  66.                    :initform (make-hash-table :weak :value :test 'eq))
  67.    (mem->pheap-hash :accessor mem->pheap-hash
  68.                    :initform (make-hash-table :weak :key :test 'eq))
  69.    (p-load-hash :accessor p-load-hash
  70.                 :initform (make-hash-table :weak :key :test 'eq))
  71.    (inside-p-load :accessor inside-p-load :initform nil)
  72.    (p-store-hash :accessor p-store-hash
  73.                  :initform (make-hash-table :weak :key :test 'eq))
  74.    (inside-p-store :accessor inside-p-store :initform nil)))
  75.    
  76.  
  77. ; A PPTR is a pointer into a PHEAP
  78. (defstruct (pptr (:print-function print-pptr))
  79.   pheap
  80.   pointer
  81.   )
  82.  
  83. (defun print-pptr (pptr stream level)
  84.   (declare (ignore level))
  85.   (write-string "#.(" stream)
  86.   (prin1 'pptr stream)
  87.   (tyo #\space stream)
  88.   (prin1 (pptr-pheap pptr) stream)
  89.   (write-string " #x" stream)
  90.   (let ((*print-base* 16))
  91.     (prin1 (pptr-pointer pptr) stream))
  92.   (tyo #\) stream))
  93.  
  94. (defun pptr (pheap pointer)
  95.   (if (eq pointer $pheap-nil)
  96.     nil
  97.     (let ((hash (pptr-hash pheap)))
  98.       (or (gethash pointer hash)
  99.           (setf (gethash pointer hash)
  100.                 (make-pptr :pheap pheap :pointer pointer))))))
  101.  
  102. ; Turns a value into a (pointer imm?) pair
  103. (defun split-pptr (maybe-pptr)
  104.   (if (pptr-p maybe-pptr)
  105.     (pptr-pointer maybe-pptr)
  106.     (values maybe-pptr t)))
  107.  
  108. (defun dc-pointer-pptr (disk-cache pointer)
  109.   (pptr (disk-cache-pheap disk-cache) pointer))
  110.  
  111. (defun pptr-disk-cache (pptr)
  112.   (pheap-disk-cache (pptr-pheap pptr)))
  113.  
  114. (defconstant $version-number #x504801)          ; current version number "PH1"
  115. (defconstant $min-version #x504801)     ; minimum version number we can deal with
  116. (defconstant $max-version #x504801)     ; maximum version number we can deal with
  117.  
  118. (defparameter *default-area-segment-size* 4096)
  119. (defparameter *default-page-size* 512)
  120. (defparameter *default-max-pages* 200)
  121.  
  122. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  123. ;;
  124. ;; Functions to create, open, and close pheaps
  125. ;;
  126.  
  127. (defmacro dc-%svfill (disk-cache vector &body indices-and-values)
  128.   (let (res)
  129.     (loop
  130.       (when (null indices-and-values) (return))
  131.       (let ((index (pop indices-and-values))
  132.             (value (pop indices-and-values))
  133.             immediate?)
  134.         (when (consp index)
  135.           (psetq index (car index) immediate? (cadr index)))
  136.         (push `(setf (dc-%svref ,disk-cache ,vector ,index ,immediate?) ,value)
  137.               res)))
  138.     `(progn ,@(nreverse res))))
  139.  
  140. ; Create a pheap. Close its file.
  141. (defun create-pheap (filename &key
  142.                               (if-exists :error)
  143.                               (area-segment-size *default-area-segment-size*)
  144.                               (page-size *default-page-size*))
  145.   (let ((min-page-size 512))
  146.     (setq page-size 
  147.           (require-type (* min-page-size (floor (+ page-size min-page-size -1) min-page-size))
  148.                         'fixnum)))
  149.   (let* ((disk-cache (open-disk-cache
  150.                       filename
  151.                       :if-exists if-exists
  152.                       :if-does-not-exist :create
  153.                       :page-size page-size
  154.                       :external-format :WOOD)))
  155.     (fill-long disk-cache 0 0 (ash (disk-cache-page-size disk-cache) -2))
  156.     (initialize-vector-storage
  157.      disk-cache (pointer-address $root-vector)
  158.      $pheap-header-size $v_dbheader 4 $pheap-nil)
  159.     (dc-%svfill disk-cache $root-vector
  160.       ($pheap.version t) $version-number
  161.       ($pheap.free-page t) 1
  162.       $pheap.default-consing-area (dc-make-area
  163.                                    disk-cache :segment-size area-segment-size)
  164.       ($pheap.page-size t) page-size)
  165.     (setf (read-string disk-cache
  166.                        (+ $root-vector (- $t_vector) (ash $pheap-header-size 2)))
  167.           #.(format nil "~%This is a persistent heap~%~
  168.                          created by William's Object Oriented Database~%~
  169.                          in Macintosh Common Lisp.~%"))
  170.     (close-disk-cache disk-cache)
  171.     filename))
  172.  
  173. (defvar *open-pheaps* nil)
  174.  
  175. (defun open-pheap (filename &rest rest
  176.                             &key
  177.                             (if-does-not-exist :error)
  178.                             (if-exists :overwrite)
  179.                             (area-segment-size *default-area-segment-size*)
  180.                             (page-size *default-page-size*)
  181.                             (max-pages (ceiling (* *default-page-size*
  182.                                                    *default-max-pages*)
  183.                                                 page-size)))
  184.   (declare (dynamic-extent rest))
  185.   (let* ((disk-cache (unless (eq if-exists :supersede)
  186.                        (open-disk-cache filename
  187.                                         :if-exists if-exists
  188.                                         :if-does-not-exist nil
  189.                                         :page-size page-size
  190.                                         :max-pages max-pages
  191.                                         :write-hook 'pheap-write-hook
  192.                                         :external-format :WOOD))))
  193.     (when (null disk-cache)
  194.       (if (or (eq if-exists :supersede)
  195.               (eq if-does-not-exist :create))
  196.         (progn
  197.           (create-pheap filename
  198.                         :if-exists if-exists
  199.                         :area-segment-size area-segment-size
  200.                         :page-size page-size)
  201.           (return-from open-pheap
  202.             (apply #'open-pheap filename :if-exists :overwrite rest)))
  203.         (error "File ~s does not exist" filename)))
  204.     (when (not (eql page-size (setq page-size (dc-%svref disk-cache $root-vector $pheap.page-size))))
  205.       (close-disk-cache disk-cache)
  206.       (return-from open-pheap
  207.         (apply #'open-pheap filename :page-size page-size rest)))
  208.     (let ((done? nil))
  209.       (unwind-protect
  210.         (progn
  211.           (lock-page-at-address disk-cache 0)   ; accessed frequently
  212.           (multiple-value-bind (count imm?) (dc-page-write-count disk-cache)
  213.             (when (or imm? (not (eql count $pheap-nil)))
  214.               (cerror "Hope for the best."
  215.                       "~s was modified but not closed properly. It may be corrupt."
  216.                       filename)
  217.               (setf (dc-page-write-count disk-cache) $pheap-nil
  218.                     (disk-cache-write-hook disk-cache) nil)
  219.               (flush-disk-cache disk-cache)
  220.               (setf (disk-cache-write-hook disk-cache) 'pheap-write-hook)))
  221.           (let ((pheap (make-instance 'pheap :disk-cache disk-cache)))
  222.             (setf (pheap-consing-area pheap) (dc-default-consing-area disk-cache))
  223.             (push pheap *open-pheaps*)
  224.             (setq done? t)
  225.             pheap))
  226.         (unless done?
  227.           (close-disk-cache disk-cache))))))
  228.  
  229. (defun close-pheap (pheap)
  230.   (flush-pheap pheap)
  231.   (close-disk-cache (pheap-disk-cache pheap))
  232.   (setq *open-pheaps* (delq pheap *open-pheaps*))
  233.   nil)
  234.  
  235. (defmacro with-open-pheap ((pheap filename &rest options) &body body)
  236.   `(let ((,pheap (open-pheap ,filename ,@options)))
  237.      (unwind-protect
  238.        (progn ,@body)
  239.        (close-pheap ,pheap))))
  240.  
  241. (defun disk-cache-pheap (disk-cache)
  242.   (dolist (pheap *open-pheaps*)
  243.     (if (eq disk-cache (pheap-disk-cache pheap))
  244.       (return pheap))))
  245.  
  246. (defun flush-pheap (pheap)
  247.   (let ((disk-cache (pheap-disk-cache pheap)))
  248.     (flush-disk-cache disk-cache)
  249.     (multiple-value-bind (count imm?) (dc-page-write-count disk-cache)
  250.       (unless (and (not imm?) (eql count $pheap-nil))
  251.         (setf (dc-page-write-count disk-cache) $pheap-nil
  252.               (disk-cache-write-hook disk-cache) nil)
  253.         (flush-disk-cache disk-cache)
  254.         (setf (disk-cache-write-hook disk-cache) 'pheap-write-hook)))))
  255.  
  256. (defun flush-all-open-pheaps ()
  257.   (dolist (pheap *open-pheaps*)
  258.     (flush-pheap pheap)))
  259.  
  260. (pushnew 'flush-all-open-pheaps *lisp-cleanup-functions*)
  261.  
  262. ; This marks the pheap as modifed so that the next open
  263. ; will complain if it was not closed properly.
  264. ; Eventually, we'll also maintain an active transactions count.
  265. (defun pheap-write-hook (disk-page)
  266.   (let ((disk-cache (disk-page-disk-cache disk-page))
  267.         flush-page-0?)
  268.     (multiple-value-bind (count imm?) (dc-page-write-count disk-cache)
  269.       (when (and (not imm?) (eql count $pheap-nil))
  270.         (setq count 0
  271.               flush-page-0? t))
  272.       (setf (dc-page-write-count disk-cache t)
  273.             (if (eql count most-positive-fixnum)
  274.               count
  275.               (1+ count)))
  276.       (when flush-page-0?
  277.         (setf (disk-cache-write-hook disk-cache) nil)
  278.         (flush-disk-page (nth-value 3 (get-disk-page disk-cache 0)))
  279.         (setf (disk-cache-write-hook disk-cache) 'pheap-write-hook)))))
  280.  
  281. (defun dc-page-write-count (disk-cache)
  282.   (dc-%svref disk-cache $root-vector $pheap.page-write-count))
  283.  
  284. (defun (setf dc-page-write-count) (value disk-cache &optional imm?)
  285.   (setf (dc-%svref disk-cache $root-vector $pheap.page-write-count imm?)
  286.         value))
  287.  
  288. (defun pheap-default-consing-area (pheap)
  289.   (multiple-value-bind (pointer immediate?)
  290.                        (dc-default-consing-area (pheap-disk-cache pheap))
  291.     (if immediate?
  292.       pointer
  293.       (pptr pheap pointer))))
  294.  
  295. (defun dc-default-consing-area (disk-cache)
  296.   (dc-%svref disk-cache
  297.              $root-vector
  298.              $pheap.default-consing-area))
  299.  
  300. (defmacro require-satisfies (predicate &rest args)
  301.   `(unless (,predicate ,@args)
  302.      (error "Not ~s" ',predicate)))
  303.  
  304. (defun (setf pheap-default-consing-area) (area pheap)
  305.   (let ((disk-cache (pheap-disk-cache pheap))
  306.         (pointer (pheap-pptr-pointer area pheap)))
  307.     (require-satisfies dc-vector-subtype-p disk-cache pointer $v_area)
  308.     (setf (dc-%svref disk-cache $root-vector $pheap.default-consing-area)
  309.           pointer))
  310.   area)
  311.  
  312.  
  313. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  314. ;;
  315. ;; Reading pheap data into the Lisp heap
  316. ;;
  317. ;; Readers take a DEPTH argument:
  318. ;; :default      The default. Load the object into memory stopping at
  319. ;;               objects that have already been loaded.
  320. ;; nil           No conversion except lookup in the hash table.
  321. ;; :single       load a single level. vectors, arrays, & lists will come out
  322. ;;               one level deep. May cons lots of pptr's
  323. ;; <fixnum>      Same as :single but will only load vectors if their length
  324. ;;               is <= depth
  325. ;; T             Recursive descent until closure. May modify some existing Lisp objects.
  326. ;;               Slower than the others as it requires clearing the descent hash table.
  327.  
  328.  
  329. (defun root-object (pheap)
  330.   (multiple-value-bind (pointer immediate?)
  331.                        (dc-%svref (pheap-disk-cache pheap) $root-vector $pheap.root)
  332.     (if immediate?
  333.       pointer
  334.       (pptr pheap pointer))))
  335.                           
  336.  
  337. (defun p-load (pptr &optional (depth :default))
  338.   (if (pptr-p pptr)
  339.     (pointer-load (pptr-pheap pptr)
  340.                   (pptr-pointer pptr)
  341.                   depth)
  342.     pptr))
  343.  
  344. (defun pointer-load (pheap pointer &optional depth disk-cache)
  345.   (unless disk-cache
  346.     (setq disk-cache (pheap-disk-cache pheap)))
  347.   (if (or (neq depth t) (inside-p-load pheap))
  348.     (pointer-load-internal pheap pointer depth disk-cache)
  349.     (unwind-protect
  350.       (progn
  351.         (setf (inside-p-load pheap) t)
  352.         (pointer-load-internal pheap pointer depth disk-cache))
  353.       (clrhash (p-load-hash pheap))
  354.       (setf (inside-p-load pheap) nil))))
  355.  
  356. (defun pointer-load-internal (pheap pointer depth disk-cache)
  357.   (let ((tag (pointer-tag pointer)))
  358.     (declare (fixnum tag))
  359.     (let ((f (locally (declare (optimize (speed 3) (safety 0)))
  360.                (svref #(p-load-immediate        ; $t_fixnum
  361.                         p-load-vector   ; $t_vector
  362.                         p-load-symbol   ; $t_symbol
  363.                         p-load-dfloat   ; $t_dfloat
  364.                         p-load-cons     ; $t_cons
  365.                         p-load-immediate        ; $t_sfloat
  366.                         p-load-lfun     ; $t_lfun
  367.                         p-load-immediate)       ; $t_imm
  368.                       tag))))
  369.       (unless (or (eq depth t) (eq f 'p-load-immediate))
  370.         (let ((res (gethash pointer (pheap->mem-hash pheap))))
  371.           (when res
  372.             (return-from pointer-load-internal res))))
  373.       (funcall f pheap disk-cache pointer depth))))
  374.  
  375. ; For error messages
  376. (defun dc-pointer-load (disk-cache pointer &optional immediate? pheap)
  377.   (if immediate?
  378.     pointer
  379.     (pointer-load (or pheap (disk-cache-pheap disk-cache)) pointer :default disk-cache)))
  380.  
  381. (defmacro maybe-cached-value (pheap pointer &body forms)
  382.   (setq pheap (require-type pheap 'symbol)
  383.         pointer (require-type pointer '(or symbol integer)))
  384.   (let ((pheap->mem-hash (make-symbol "PHEAP->MEM-HASH"))
  385.         (value (make-symbol "VALUE")))
  386.     `(let ((,pheap->mem-hash (pheap->mem-hash ,pheap)))
  387.        (or (gethash ,pointer ,pheap->mem-hash)
  388.            (let ((,value (progn ,@forms)))
  389.              (if (pptr-p ,value)    ; you should throw out in this case.
  390.                ,value
  391.                (setf (gethash ,value (mem->pheap-hash ,pheap)) ,pointer
  392.                      (gethash ,pointer ,pheap->mem-hash) ,value)))))))
  393.  
  394. (defmacro maybe-cached-address (pheap object &body forms)
  395.   (setq pheap (require-type pheap 'symbol)
  396.         object (require-type object 'symbol))
  397.   (let ((mem->pheap-hash (make-symbol "MEM->PHEAP-HASH"))
  398.         (address (make-symbol "ADDRESS")))
  399.     `(let ((,mem->pheap-hash (mem->pheap-hash ,pheap)))
  400.        (or (gethash ,object ,mem->pheap-hash)
  401.            (let ((,address (progn ,@forms)))
  402.              (setf (gethash ,address (pheap->mem-hash ,pheap)) ,object
  403.                    (gethash ,object ,mem->pheap-hash) ,address))))))
  404.  
  405. (defun p-load-immediate (pheap disk-cache pointer depth)
  406.   (declare (ignore disk-cache depth))
  407.   (error "Immediate pointer ~s" (pptr pheap pointer)))
  408.  
  409. (defparameter *p-load-subtype-functions*
  410.   #(p-load-error                        ;($v_packed_sstr 0)
  411.     p-load-ivector                      ;($v_bignum 1)
  412.     p-load-error                        ;($v_macptr 2) - not supported
  413.     p-load-ivector                      ;($v_badptr 3)
  414.     p-load-lfun-vector                  ;($v_nlfunv 4)
  415.     p-load-error                        ;subtype 5 unused
  416.     p-load-error                        ;subtype 6 unused
  417.     p-load-ivector                      ;($v_ubytev 7)    ;unsigned byte vector
  418.     p-load-ivector                      ;($v_uwordv 8)    ;unsigned word vector
  419.     p-load-ivector                      ;($v_floatv 9)    ;float vector
  420.     p-load-ivector                      ;($v_slongv 10)   ;Signed long vector
  421.     p-load-ivector                      ;($v_ulongv 11)   ;Unsigned long vector
  422.     p-load-ivector                      ;($v_bitv 12)     ;Bit vector
  423.     p-load-ivector                      ;($v_sbytev 13)   ;Signed byte vector
  424.     p-load-ivector                      ;($v_swordv 14)   ;Signed word vector
  425.     p-load-ivector                      ;($v_sstr 15)     ;simple string
  426.     p-load-gvector                      ;($v_genv 16)     ;simple general vector
  427.     p-load-header                       ;($v_arrayh 17)   ;complex array header
  428.     p-load-istruct                      ;($v_struct 18)   ;structure
  429.     p-load-error                        ;($v_mark 19)     ;buffer mark
  430.     p-load-pkg                          ;($v_pkg 20)
  431.     p-load-error                        ;subtype 21 unused
  432.     p-load-istruct                      ;($v_istruct 22)
  433.     p-load-ivector                      ;($v_ratio 23)
  434.     p-load-ivector                      ;($v_complex 24)
  435.     p-load-instance                     ;($v_instance 25) ;clos instance
  436.     p-load-error                        ;subtype 26 unused
  437.     p-load-error                        ;subtype 27 unused
  438.     p-load-error                        ;subtype 28 unused
  439.     p-load-header                       ;($v_weakh 29)
  440.     p-load-header                       ;($v_poolfreelist 30)
  441.     p-load-header                       ;($v_nhash 31)
  442.     ; internal subtypes
  443.     p-load-nop                          ;($v_area 32)
  444.     p-load-nop                          ;($v_segment 33)
  445.     p-load-nop                          ;($v_random-bits 34)
  446.     p-load-nop                          ;($v_dbheader 35)
  447.     p-load-nop                          ;($v_segment-headers 36)
  448.     p-load-nop                          ;($v_btree 37)
  449.     p-load-nop                          ;($v_btree-node 38)
  450.     p-load-class                        ;($v_class 39)
  451.     ))
  452.  
  453. (defun p-load-vector (pheap disk-cache pointer depth)
  454.   (let ((subtype (dc-%vector-subtype disk-cache pointer)))
  455.     (declare (fixnum subtype))
  456.     (let ((f (svref *p-load-subtype-functions* subtype)))
  457.       (if f
  458.         (funcall f pheap disk-cache pointer depth subtype)
  459.         (pptr pheap pointer)))))
  460.  
  461. (defun p-load-error (pheap disk-cache pointer depth subtype)
  462.   (declare (ignore disk-cache depth))
  463.   (error "~x is of unsupported subtype: ~s" (pptr pheap pointer) subtype))
  464.  
  465. (defun p-load-nop (pheap disk-cache pointer depth subtype)
  466.   (declare (ignore disk-cache depth subtype))
  467.   (pptr pheap pointer))
  468.  
  469.  
  470. (defmacro wood->ccl-subtype (wood-subtype)
  471.   `(* 2 ,wood-subtype))
  472.  
  473. (defmacro ccl->wood-subtype (ccl-subtype)
  474.   `(ash ,ccl-subtype -1))
  475.   
  476.  
  477. ; general vector
  478. (defun p-load-gvector (pheap disk-cache pointer depth subtype &optional
  479.                              special-index-p special-index-value)
  480.   (let* (length
  481.          (cached? t)
  482.          (vector (maybe-cached-value pheap pointer
  483.                    (setq cached? nil
  484.                          length  (dc-%simple-vector-length disk-cache pointer))
  485.                    (if (or (null depth)
  486.                            (and (fixnump depth) (< depth length)))
  487.                      (return-from p-load-gvector (pptr pheap pointer))
  488.                      (ccl::%make-uvector length (wood->ccl-subtype subtype))))))
  489.     (when (or (not cached?)
  490.               (listp depth)
  491.               (and (eq depth t)
  492.                    (let ((p-load-hash (p-load-hash pheap)))
  493.                      (unless (gethash vector p-load-hash)
  494.                        (setf (gethash vector p-load-hash) vector)))))
  495.       (let ((next-level-depth (cond ((or (eq depth :single) (fixnump depth)) nil)
  496.                                      ((listp depth) (car depth))
  497.                                      (t depth))))
  498.         (dotimes (i (or length (uvsize vector)))
  499.           (setf (uvref vector i)
  500.                 (if (and special-index-p (funcall special-index-p i))
  501.                   (funcall special-index-value disk-cache pointer i)
  502.                   (multiple-value-bind (pointer immediate?)
  503.                                        (dc-%svref disk-cache pointer i)
  504.                     (if immediate?
  505.                       pointer
  506.                       (pointer-load pheap pointer next-level-depth disk-cache))))))))
  507.     vector))
  508.  
  509. (defun p-load-header (pheap disk-cache pointer depth subtype &optional
  510.                             special-index-p special-index-value)
  511. ;  (declare (type (integer 0 256) subtype))
  512.   (if (eq depth t)
  513.     (p-load-gvector pheap disk-cache pointer depth subtype
  514.                     special-index-p special-index-value)
  515.     (let ((depth-list (list depth)))
  516.       (declare (dynamic-extent depth-list))
  517.       (p-load-gvector pheap disk-cache pointer depth-list subtype
  518.                       special-index-p special-index-value))))
  519.  
  520. (defun p-load-istruct (pheap disk-cache pointer depth subtype)
  521.   (declare (dynamic-extent #'special-index-value))
  522.   (p-load-gvector pheap disk-cache pointer depth subtype
  523.                   #'(lambda (index) (eql index 0))
  524.                   #'(lambda (disk-cache pointer index)
  525.                       (multiple-value-bind (p imm?) (dc-%svref disk-cache pointer index)
  526.                         (if imm?
  527.                           p
  528.                           (pointer-load (disk-cache-pheap disk-cache)
  529.                                         p
  530.                                         :default
  531.                                         disk-cache))))))
  532.  
  533. (defparameter *subtype->bytes-per-element*
  534.   #(nil                                 ; 0 - unused
  535.     2                                   ; 1 - $v_bignum
  536.     nil                                 ; 2 - $v_macptr - not supported
  537.     4                                   ; 3 - $v_badptr
  538.     2                                   ; 4 - $v_nlfunv
  539.     nil                                 ; 5 - unused
  540.     nil                                 ; 6 - unused
  541.     1                                   ; 7 - $v_ubytev - unsigned byte vector
  542.     2                                   ; 8 - $v_uwordv - unsigned word vector
  543.     8                                   ; 9 - $v_floatv - float vector
  544.     4                                   ; 10 - $v_slongv - Signed long vector
  545.     4                                   ; 11 - $v_ulongv - Unsigned long vector
  546.     nil                                   ; 12 - $v_bitv - Bit vector (handled specially)
  547.     1                                   ; 13 - $v_sbytev - Signed byte vector
  548.     2                                   ; 14 - $v_swordv - Signed word vector
  549.     1                                   ; 15 - $v_sstr - simple string
  550.     4                                   ; 16 - $v_genv - simple general vector
  551.     4                                   ; 17 - $v_arrayh - complex array header
  552.     4                                   ; 18 - $v_struct - structure
  553.     nil                                 ; 19 - $v_mark - buffer mark unimplemented
  554.     4                                   ; 20 - $v_pkg
  555.     nil                                 ; 21 - unused
  556.     4                                   ; 22 - $v_istruct - type in first element
  557.     4                                   ; 23 - $v_ratio
  558.     4                                   ; 24 - $v_complex
  559.     4                                   ; 25 - $v_instance - clos instance
  560.     nil                                 ; 26 - unused
  561.     nil                                 ; 27 - unused
  562.     nil                                 ; 28 - unused
  563.     4                                   ; 29 - $v_weakh - weak list header
  564.     4                                   ; 30 - $v_poolfreelist - free pool header
  565.     4                                   ; 31 - $v_nhash
  566.     ; WOOD specific subtypes
  567.     4                                   ; 32 - $v_area - area descriptor
  568.     4                                   ; 33 - $v_segment - area segment
  569.     1                                   ; 34 - $v_random-bits - vectors of random bits, e.g. resources
  570.     4                                   ; 35 - $v_dbheader - database header
  571.     nil                                 ; 36 - $v_segment-headers - specially allocated
  572.     4                                   ; 37 - $v_btree
  573.     nil                                 ; 38 - $v_btree-node - specially allocated
  574.     4                                   ; 39 - $v_class
  575.     ))
  576.  
  577. ; ivectors
  578. (defun p-load-ivector (pheap disk-cache pointer depth subtype)
  579.   (declare (fixnum subtype))
  580.   (let* ((cached? t)
  581.          (res (maybe-cached-value pheap pointer
  582.                 (setq cached? nil)
  583.                 (let ((length (dc-uvsize disk-cache pointer))
  584.                       (size (dc-%vector-size disk-cache pointer)))
  585.                   (if (and depth
  586.                            (or (not (fixnump depth)) (<= length depth)))
  587.                     (load-byte-array
  588.                      disk-cache (addr+ disk-cache pointer $v_data) size
  589.                      (ccl::%make-uvector length (wood->ccl-subtype subtype))
  590.                      0 t)
  591.                     (return-from p-load-ivector (pptr pheap pointer)))))))
  592.     (when (and cached? (eq depth t))
  593.       (let* ((size (dc-%vector-size disk-cache pointer))
  594.              (subtype (dc-%vector-subtype disk-cache pointer)))
  595.         (unless (eql (uvsize res) (dc-uvsize disk-cache pointer))
  596.           (error "Inconsistency. Disk ivector is different size than in-memory version."))
  597.         (unless (eql (wood->ccl-subtype subtype)
  598.                      (ccl::%vect-subtype res))
  599.           (error "Inconsistency. Subtype mismatch."))
  600.         (load-byte-array disk-cache (addr+ disk-cache pointer $v_data) size res 0 t)))
  601.     res))
  602.  
  603. (defun p-load-lfun-vector (pheap disk-cache pointer depth subtype)
  604.   (declare (ignore pheap disk-cache pointer depth subtype))
  605.   (error "Inconsitency: WOOD does not tag vectors as ~s" '$t_lfunv))
  606.  
  607. (defun p-load-pkg (pheap disk-cache pointer depth subtype)
  608.   (declare (ignore depth subtype))
  609.   (maybe-cached-value pheap pointer
  610.     (let* ((names (pointer-load-internal pheap (dc-%svref disk-cache pointer $pkg.names)
  611.                                          t disk-cache))
  612.            (name (car names)))
  613.       (or (find-package name)
  614.           (make-package name :nicknames (cdr names) :use nil)))))
  615.  
  616. ;; End of loaders for $t_vector subtypes
  617.  
  618. (defun p-load-symbol (pheap disk-cache pointer depth)
  619.   (declare (ignore depth))
  620.   (maybe-cached-value pheap pointer
  621.     (intern (pointer-load-internal
  622.              pheap (read-long disk-cache (+ pointer $sym_pname)) :default disk-cache)
  623.             (pointer-load-internal
  624.              pheap (read-long disk-cache (+ pointer $sym_package)) :default disk-cache))))
  625.  
  626. (defun p-load-dfloat (pheap disk-cache pointer depth)
  627.   (maybe-cached-value pheap pointer
  628.     (if (eq depth nil)
  629.       (return-from p-load-dfloat (pptr pheap pointer)))
  630.     (values (read-double-float disk-cache (- pointer $t_dfloat)) t)))
  631.  
  632. (defun p-load-cons (pheap disk-cache pointer depth)
  633.   (declare (ignore subtype))
  634.   (if (eql pointer $pheap-nil)
  635.     nil
  636.     (let* ((cached? t)
  637.            (cons (maybe-cached-value pheap pointer
  638.                    (setq cached? nil)
  639.                    (if (or (null depth) (and (fixnump depth) (<= depth 0)))
  640.                      (return-from p-load-cons (pptr pheap pointer))
  641.                      (cons nil nil)))))
  642.       (when (or (not cached?)
  643.                 (and (eq depth t)
  644.                      (let ((p-load-hash (p-load-hash pheap)))
  645.                        (unless (gethash cons p-load-hash)
  646.                          (setf (gethash cons p-load-hash) cons)))))
  647.         (let ((next-level-depth (unless (or (eq depth :single) (fixnump depth))
  648.                                   depth))
  649.               (rest-depth (if (fixnump depth) (1- depth) depth)))
  650.           (multiple-value-bind (car car-imm?) (read-pointer disk-cache (- pointer $t_cons))
  651.             (multiple-value-bind (cdr cdr-imm?) (read-pointer disk-cache pointer)
  652.               (setf (car cons)
  653.                     (if car-imm?
  654.                       car
  655.                       (pointer-load pheap car next-level-depth disk-cache)))
  656.               (setf (cdr cons)
  657.                     (if cdr-imm?
  658.                       cdr
  659.                       (pointer-load pheap cdr rest-depth disk-cache)))))))
  660.       cons)))
  661.  
  662. (defun p-load-lfun (pheap disk-cache pointer depth)
  663.   (maybe-cached-value pheap pointer
  664.     (if (null depth)
  665.       (return-from p-load-lfun (pptr pheap pointer))
  666.       (let* ((vector-pointer (+ pointer (- $t_vector $t_lfun)))
  667.              (vector (p-load-vector pheap disk-cache vector-pointer :default)))
  668.         (ccl::applyv #'join-lfun vector)))))
  669.  
  670. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  671. ;;;
  672. ;;; Writing Lisp data into the pheap
  673. ;;;
  674.  
  675. ;;; The descend argument can take three values:
  676. ;;;
  677. ;;; :default     The default. Don't descend if you find an address in the cache
  678. ;;; nil          Same as :default, but newly consed values are not cached.
  679. ;;;              Allows storing stack-consed objects in the persistent heap.
  680. ;;; t            Recursively descend and overwrite any cached values.
  681.  
  682. (defun (setf root-object) (new-root pheap)
  683.   (multiple-value-bind (pointer immediate?) (%p-store pheap new-root)
  684.     (setf (dc-%svref (pheap-disk-cache pheap) $root-vector $pheap.root immediate?)
  685.           pointer)
  686.     (if immediate?
  687.       pointer
  688.       (pptr pheap pointer))))
  689.  
  690. (defun p-store (pheap object &optional (descend :default))
  691.   (multiple-value-bind (pointer immediate?) (%p-store pheap object descend)
  692.     (if (or immediate? (null pointer))
  693.       pointer
  694.       (pptr pheap pointer))))
  695.  
  696. (defun require-pptr-pheap (pptr pheap)
  697.   (unless (eq (pptr-pheap pptr) pheap)
  698.     (error "wrong pheap!")))
  699.  
  700. (defun pheap-pptr-pointer (pptr pheap)
  701.   (require-pptr-pheap pptr pheap)
  702.   (pptr-pointer pptr))
  703.  
  704. (defun %p-store (pheap object &optional (descend :default))
  705.   (unless (or (eq descend :default)
  706.               (null descend)
  707.               (eq descend t))
  708.     (setq descend (require-type descend '(member :default nil t))))
  709.   (cond ((ccl::dtagp object (+ (ash 1 ccl::$t_fixnum) 
  710.                                (ash 1 ccl::$t_sfloat)
  711.                                (ash 1 ccl::$t_imm)))
  712.          (values object t))
  713.         ((typep object 'pptr)
  714.          (require-pptr-pheap object pheap)
  715.          (pptr-pointer object))
  716.         (t (if (or (eq descend :default) (inside-p-store pheap))
  717.              (%p-store-internal pheap object descend)
  718.              (unwind-protect
  719.                (progn
  720.                  (setf (inside-p-store pheap) t)
  721.                  (%p-store-internal pheap object descend))
  722.                (clrhash (p-store-hash pheap))
  723.                (setf (inside-p-store pheap) nil))))))
  724.  
  725. (defun %p-store-internal (pheap object descend)
  726.   (if (ccl::dtagp object (logior (ash 1 ccl::$t_fixnum) 
  727.                                  (ash 1 ccl::$t_sfloat)
  728.                                  (ash 1 ccl::$t_imm)))
  729.     (values object t)
  730.     (or (and (neq descend t) (gethash object (p-store-hash pheap)))
  731.         (%p-store-object pheap object descend))))
  732.  
  733. (defmethod %p-store-object (pheap (object pptr) descend)
  734.   (declare (ignore descend))
  735.   (require-pptr-pheap object pheap)
  736.   (pptr-pointer object))
  737.  
  738. (defmethod %p-store-object (pheap (object symbol) descend)
  739.   (if (null object)
  740.     $pheap-nil
  741.     (maybe-cached-address pheap object
  742.       (let ((address (dc-intern (pheap-disk-cache pheap)
  743.                                 (symbol-name object)
  744.                                 (symbol-package object)
  745.                                 t
  746.                                 (pheap-consing-area pheap)
  747.                                 pheap)))
  748.         (when (eq descend nil)
  749.           (return-from %p-store-object address))
  750.         address))))
  751.  
  752. (defmethod %p-store-object (pheap (object null) descend)
  753.   (declare (ignore pheap descend))
  754.   $pheap-nil)
  755.  
  756. (defmethod %p-store-object (pheap (object function) descend)
  757.   (declare (ignore descend))
  758.   (maybe-cached-address pheap object
  759.     (let* ((split-vec (apply #'vector (split-lfun object)))
  760.            (address (%p-store pheap split-vec)))
  761.       (+ address (- $t_lfun $t_vector)))))           
  762.  
  763. ; This happenned three times so I made it into a macro.
  764. (defmacro %p-store-object-body ((pheap object descend disk-cache address)
  765.                                 &body body)
  766.   (unless (null (cddr body))
  767.     (error "body must be of the form (conser filler)"))
  768.   (let ((conser (car body))
  769.         (filler (cadr body))
  770.         (conser-var (gensym))
  771.         (filler-var (gensym)))
  772.     `(let ((,conser-var #'(lambda (,disk-cache ,object)
  773.                             (declare (ignore-if-unused ,object))
  774.                             ,conser))
  775.            (,filler-var #'(lambda (,pheap ,disk-cache ,object ,address ,descend)
  776.                             (declare (ignore-if-unused ,pheap ,descend))
  777.                             ,filler)))
  778.        (declare (dynamic-extent ,conser-var ,filler-var))
  779.        (do-%p-store-object-body pheap object descend ,conser-var ,filler-var))))
  780.  
  781. ; The REMHASH'es below are totally misguided. To do this right,
  782. ; it needs to be a transaction.
  783. (defun do-%p-store-object-body (pheap object descend conser filler)
  784.   (let* ((disk-cache (pheap-disk-cache pheap))
  785.          (cached? t)
  786.          (address nil)
  787.          (decache? nil)
  788.          (un-p-store-hash? nil))
  789.     (unwind-protect
  790.       (progn
  791.         (block avoid-p-store-hash
  792.           (setq address (block avoid-cache
  793.                           (maybe-cached-address pheap object
  794.                             (when (eq descend nil)
  795.                               (when (setq address (gethash object (p-store-hash pheap)))
  796.                                 (setq un-p-store-hash? t)
  797.                                 (return-from avoid-p-store-hash address)))
  798.                             (setq cached? nil
  799.                                   decache? t)
  800.                             (prog1
  801.                               (setq address (funcall conser disk-cache object))
  802.                               (when (eq descend nil)
  803.                                 (setq decache? nil)
  804.                                 (return-from avoid-cache address))))))
  805.           (unless (eq descend :default)
  806.             (let ((p-store-hash (p-store-hash pheap)))
  807.               (unless (and descend (gethash object p-store-hash))
  808.                 (setf (gethash object p-store-hash) address)
  809.                 (setq un-p-store-hash? t)
  810.                 (when (eq descend t)
  811.                   (setq cached? nil))))))
  812.         (unless cached?
  813.           (funcall filler pheap disk-cache object address descend))
  814.         (setq decache? nil
  815.               un-p-store-hash? nil))
  816.       (when decache?
  817.         (remhash object (mem->pheap-hash pheap))
  818.         (remhash address (pheap->mem-hash pheap)))
  819.       (when un-p-store-hash?
  820.         (remhash object (p-store-hash pheap))))
  821.     address))
  822.  
  823. (defmethod %p-store-object (pheap (object cons) descend)
  824.   (%p-store-object-body (pheap object descend disk-cache address)
  825.     (dc-cons disk-cache $pheap-nil $pheap-nil)
  826.     (progn
  827.       (multiple-value-bind (car car-imm?) (%p-store pheap (car object) descend)
  828.         (setf (dc-car disk-cache address car-imm?) car))
  829.       (multiple-value-bind (cdr cdr-imm?) (%p-store pheap (cdr object) descend)
  830.         (setf (dc-cdr disk-cache address cdr-imm?) cdr)))))
  831.  
  832. (defmethod %p-store-object (pheap (object double-float) descend)
  833.   (maybe-cached-address pheap object
  834.     (let ((address (dc-cons-float (pheap-disk-cache pheap)
  835.                                   object
  836.                                   (pheap-consing-area pheap))))
  837.       (when (eq descend nil)
  838.         (return-from %p-store-object address))
  839.       address)))
  840.  
  841. (defun p-cons-float (pheap float)
  842.   (pptr pheap (dc-cons-float (pheap-disk-cache pheap) float)))       
  843.  
  844. (defun dc-cons-float (disk-cache value &optional area)
  845.   (setq value (require-type value 'float))
  846.   (let ((address (%allocate-storage disk-cache area 8)))
  847.     (setf (read-double-float disk-cache (decf address $t_cons)) value)
  848.     (+ $t_dfloat address)))
  849.  
  850. (defmethod %p-store-object (pheap (object package) descend)
  851.   (maybe-cached-address pheap object
  852.     (let ((address (dc-find-or-make-package (pheap-disk-cache pheap) object t)))
  853.       (when (eq descend nil)
  854.         (return-from %p-store-object address))
  855.       address)))
  856.  
  857. (defmethod %p-store-object (pheap (object t) descend)
  858.   (if (uvectorp object)
  859.     (%p-store-uvector pheap object descend)
  860.     (error "Don't know how to store ~s" object)))
  861.         
  862. (defparameter *p-store-subtype-functions*
  863.   #(nil                                 ;($v_packed_sstr 0)
  864.     p-store-ivector                     ;($v_bignum 1)
  865.     nil                                 ;($v_macptr 2) - not supported
  866.     p-store-ivector                     ;($v_badptr 3)
  867.     p-store-lfun-vector                 ;($v_nlfunv 4)
  868.     nil                                 ;subtype 5 unused
  869.     nil                                 ;subtype 6 unused
  870.     p-store-ivector                     ;($v_ubytev 7)    ;unsigned byte vector
  871.     p-store-ivector                     ;($v_uwordv 8)    ;unsigned word vector
  872.     p-store-ivector                     ;($v_floatv 9)    ;float vector
  873.     p-store-ivector                     ;($v_slongv 10)   ;Signed long vector
  874.     p-store-ivector                     ;($v_ulongv 11)   ;Unsigned long vector
  875.     p-store-ivector                     ;($v_bitv 12)     ;Bit vector
  876.     p-store-ivector                     ;($v_sbytev 13)   ;Signed byte vector
  877.     p-store-ivector                     ;($v_swordv 14)   ;Signed word vector
  878.     p-store-ivector                     ;($v_sstr 15)     ;simple string
  879.     p-store-gvector                     ;($v_genv 16)     ;simple general vector
  880.     p-store-gvector                     ;($v_arrayh 17)   ;complex array header
  881.     p-store-gvector                     ;($v_struct 18)   ;structure
  882.     nil                                 ;($v_mark 19)     ;buffer mark
  883.     nil                                 ;($v_pkg 20)
  884.     nil                                 ;subtype 21 unused
  885.     p-store-gvector                     ;($v_istruct 22)
  886.     p-store-ivector                     ;($v_ratio 23)
  887.     p-store-ivector                     ;($v_complex 24)
  888.     nil                                 ;($v_instance 25) ;clos instance
  889.     nil                                 ;subtype 26 unused
  890.     nil                                 ;subtype 27 unused
  891.     nil                                 ;subtype 28 unused
  892.     p-store-gvector                     ;($v_weakh 29)
  893.     p-store-gvector                     ;($v_poolfreelist 30)
  894.     p-store-gvector                     ;($v_nhash 31)
  895.     ))
  896.  
  897. (defun %p-store-uvector (pheap object descend)
  898.   (let* ((length (uvsize object))
  899.          (subtype (ccl->wood-subtype (ccl::%vect-subtype object)))
  900.          (store-function (or (svref *p-store-subtype-functions* subtype)
  901.                              (error "Can't store vector of subtype ~s: ~s" subtype object))))
  902.     (%p-store-object-body (pheap object descend disk-cache address)
  903.       (dc-make-uvector disk-cache length subtype)
  904.       (funcall store-function pheap object descend disk-cache address length))))
  905.  
  906. (defun p-store-gvector (pheap object descend disk-cache address length)
  907.   (dotimes (i length)
  908.     (multiple-value-bind (element imm?) (%p-store pheap (uvref object i) descend)
  909.       (setf (dc-%svref disk-cache address i imm?) element))))
  910.  
  911. (defun p-store-ivector (pheap object descend disk-cache address length)
  912.   (declare (ignore pheap descend length))
  913.   (let* ((bytes (dc-%vector-size disk-cache address)))
  914.     (store-byte-array object disk-cache (addr+ disk-cache address $v_data) bytes 0 t)))
  915.  
  916. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  917. ;;
  918. ;; Useful macros for predicates and accessors
  919. ;;
  920.  
  921. (defmacro p-dispatch (p if-pptr otherwise &optional make-pptr? apply?)
  922.   (let ((p (if (listp p) (car p) p))
  923.         (args (if (listp p) (cdr p))))
  924.     (flet ((add-apply (form)
  925.              (if apply?
  926.                `(apply #',(car form) ,@(cdr form))
  927.                form)))
  928.       `(if (typep ,p 'pptr)
  929.          (locally (declare (type pptr ,p) (optimize (speed 3) (safety 0)))
  930.            ,(if make-pptr?
  931.               (let ((pheap (make-symbol "PHEAP"))
  932.                     (disk-cache (make-symbol "DISK-CACHE"))
  933.                     (pointer (make-symbol "POINTER"))
  934.                     (immediate? (make-symbol "IMMEDIATE?")))
  935.                 `(let* ((,pheap (pptr-pheap ,p))
  936.                         (,disk-cache (pheap-disk-cache ,pheap)))
  937.                    (multiple-value-bind (,pointer ,immediate?)
  938.                                         ,(add-apply
  939.                                           `(,if-pptr ,disk-cache (pptr-pointer ,p) ,@args))
  940.                      (if ,immediate?
  941.                        ,pointer
  942.                        (pptr ,pheap ,pointer)))))
  943.               (add-apply `(,if-pptr (pptr-disk-cache ,p)
  944.                                     (pptr-pointer ,p)
  945.                                     ,@args))))
  946.          ,(add-apply `(,otherwise ,p ,@args))))))
  947.  
  948. (eval-when (:compile-toplevel :load-toplevel :execute)
  949.   (defun symbol-append (&rest syms)
  950.     (let ((res (string (pop syms))))
  951.       (loop
  952.         (when (null syms) (return))
  953.         (setq res (concatenate 'string res "-" (string (pop syms)))))
  954.       (intern res))))
  955.       
  956. (defmacro def-predicate (lisp-predicate (p disk-cache pointer) &body body)
  957.   (let ((p-name (symbol-append 'p lisp-predicate))
  958.         (dc-name (symbol-append 'dc lisp-predicate)))
  959.     `(progn
  960.        (defun ,p-name (,p)
  961.          (p-dispatch ,p ,dc-name ,lisp-predicate))
  962.        (defun ,dc-name (,disk-cache ,pointer)
  963.          ,@body))))
  964.  
  965. (defmacro def-accessor (lisp-accessor (p . args) (disk-cache pointer)
  966.                                       &body body)
  967.   (let ((p-name (symbol-append 'p lisp-accessor))
  968.         (dc-name (symbol-append 'dc lisp-accessor))
  969.         (args-sans-keywords (remove lambda-list-keywords args
  970.                                     :test #'(lambda (ll arg) (memq arg ll))))
  971.         (rest-arg? (let ((l (cdr (memq '&rest args))))
  972.                      (when l
  973.                        (when (cdr l) (error "rest arg must be last"))
  974.                        (car l)))))
  975.     `(progn
  976.        (defun ,p-name (,p ,@args)
  977.          ,@(if rest-arg? `((declare (dynamic-extent ,rest-arg?))))
  978.          (p-dispatch (,p ,@args-sans-keywords)
  979.                      ,dc-name ,lisp-accessor t ,rest-arg?))
  980.        (defun ,dc-name (,disk-cache ,pointer ,@args)
  981.          ,@body))))
  982.  
  983. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  984. ;;;
  985. ;;; Predicates
  986. ;;;
  987.  
  988. ; p-simple-string-p & dc-simple-string-p
  989. (def-predicate simple-string-p (p disk-cache pointer)
  990.   (dc-vector-subtype-p disk-cache pointer $v_sstr))
  991.  
  992. ; p-simple-vector-p & dc-simple-vector-p
  993. (def-predicate simple-vector-p (p disk-cache pointer)
  994.   (dc-vector-subtype-p disk-cache pointer $v_genv))
  995.  
  996. (defun dc-vector-subtype-p (disk-cache pointer subtype)
  997.   (declare (fixnum subtype))
  998.   (and (pointer-tagp pointer $t_vector)
  999.        (eql (read-8-bits disk-cache (+ pointer $v_subtype)) subtype)))
  1000.  
  1001. (def-predicate consp (p disk-cache pointer)
  1002.   (declare (ignore disk-cache))
  1003.   (pointer-tagp pointer $t_cons))
  1004.  
  1005. (def-predicate listp (p disk-cache pointer)
  1006.   (declare (ignore disk-cache))
  1007.   (or (eql pointer $pheap-nil)
  1008.       (pointer-tagp pointer $t_cons)))
  1009.  
  1010. (defun p-atom (p)
  1011.   (not (p-consp p)))
  1012.  
  1013. (defun dc-atom (disk-cache pointer)
  1014.   (not (dc-consp disk-cache pointer)))
  1015.  
  1016. (def-predicate uvectorp (p disk-cache pointer)
  1017.   (declare (ignore disk-cache))
  1018.   (eq $t_vector (pointer-tag pointer)))
  1019.  
  1020. (def-predicate packagep (p disk-cache pointer)
  1021.   (dc-vector-subtype-p disk-cache pointer $v_pkg))
  1022.  
  1023. (def-predicate symbolp (p disk-cache pointer)
  1024.   (declare (ignore disk-cache))
  1025.   (pointer-tagp pointer $t_symbol))
  1026.  
  1027. (def-predicate arrayp (p disk-cache pointer)
  1028.   (and (pointer-tagp pointer $t_vector)
  1029.        (let ((subtype (dc-%vector-subtype disk-cache pointer)))
  1030.          (declare (fixnum subtype))
  1031.          (and (<= $v_min_arr subtype) (<= subtype $v_arrayh)))))
  1032.  
  1033. (defun dc-array-subtype-satisfies-p (disk-cache array predicate)
  1034.   (and (pointer-tagp array $t_vector)
  1035.        (let ((subtype (dc-%vector-subtype disk-cache array)))
  1036.          (if (eql $v_arrayh subtype)
  1037.            (values
  1038.             (funcall predicate
  1039.                      (ccl->wood-subtype (dc-%arrayh-type disk-cache array)))
  1040.             t)
  1041.            (funcall predicate subtype)))))
  1042.  
  1043. (def-predicate stringp (p disk-cache pointer)
  1044.   (multiple-value-bind (stringp arrayhp)
  1045.                        (dc-array-subtype-satisfies-p
  1046.                         disk-cache pointer
  1047.                         #'(lambda (x) (eql x $v_sstr)))
  1048.     (and stringp
  1049.          (or (not arrayhp)
  1050.              (eql $arh_one_dim (dc-%arrayh-rank4 disk-cache pointer))))))
  1051.  
  1052. (def-predicate vectorp (p disk-cache pointer)
  1053.   (multiple-value-bind (arrayp arrayhp)
  1054.                        (dc-array-subtype-satisfies-p
  1055.                         disk-cache pointer
  1056.                         #'(lambda (x) 
  1057.                             (declare (fixnum x))
  1058.                             (and (<= $v_min_arr x) (< x $v_arrayh))))
  1059.     (and arrayp
  1060.          (or (not arrayhp)
  1061.              (eql $arh_one_dim (dc-%arrayh-rank4 disk-cache pointer))))))
  1062.  
  1063. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  1064. ;;
  1065. ;; Accessors
  1066.  
  1067. ; Returns vector size in BYTES
  1068. (defun dc-%vector-size (disk-cache v-pointer)
  1069.   (read-low-24-bits disk-cache (+ v-pointer $v_log)))
  1070.  
  1071. (def-accessor svref (v index) (disk-cache v-pointer)
  1072.   (require-satisfies dc-simple-vector-p disk-cache v-pointer)
  1073.   (let ((length (dc-%simple-vector-length disk-cache v-pointer)))
  1074.     (unless (< -1 index length)
  1075.       (error "Index ~s out of bounds in ~s"
  1076.              (dc-pointer-pptr disk-cache v-pointer))))
  1077.   (dc-%svref disk-cache v-pointer index))
  1078.  
  1079. (defun (setf p-svref) (value v index &optional immediate?)
  1080.   (declare (ignore value v index immediate?))
  1081.   (error "Not implemeneted"))
  1082.  
  1083. (defun (setf dc-svref) (value disk-cache v-pointer index &optional immediate?)
  1084.   (require-satisfies dc-simple-vector-p disk-cache v-pointer)
  1085.   (let ((length (dc-%simple-vector-length disk-cache v-pointer)))
  1086.     (unless (< -1 index length)
  1087.       (error "Index ~s out of bounds in ~s"
  1088.              (dc-pointer-pptr disk-cache v-pointer))))
  1089.   (setf (dc-%svref disk-cache v-pointer index immediate?) value))
  1090.  
  1091. ; Here's where the $block-overhead is skipped
  1092. (defun addr+ (disk-cache address offset)
  1093.   (let* ((page-size (disk-cache-page-size disk-cache))
  1094.          (mask (disk-cache-mask disk-cache))
  1095.          (start-page 0)
  1096.          (page-offset 0)
  1097.          (offset (require-type offset 'fixnum)))
  1098.     (declare (fixnum page-size mask page-offset blocks-crossed offset))
  1099.     (macrolet ((doit ()
  1100.                  `(progn
  1101.                     (setq start-page (logand address mask)
  1102.                           page-offset (- address (incf start-page $block-overhead)))
  1103.                     (incf page-offset offset)
  1104.                     (when (>= page-offset (decf page-size $block-overhead))
  1105.                       (incf page-offset
  1106.                             (the fixnum (* $block-overhead
  1107.                                            (the fixnum (floor page-offset page-size))))))
  1108.                     (+ start-page page-offset))))
  1109.       ; This will usually be called with fixnum addresses.
  1110.       ; It gets called a lot, so the optimization is worthwhile
  1111.       (if (fixnump address)
  1112.         (locally (declare (fixnum address start-page))
  1113.           (doit))
  1114.         (doit)))))
  1115.  
  1116. (def-accessor ccl::%svref (v index) (disk-cache v-pointer)
  1117.   (read-pointer
  1118.    disk-cache
  1119.    (addr+ disk-cache v-pointer (+ (ash index 2) $v_data))))
  1120.  
  1121. (defun (setf p-%svref) (value v index &optional immediate?)
  1122.   (declare (ignore value v index immediate?))
  1123.   (error "Not implemeneted"))
  1124.  
  1125. (defun (setf dc-%svref) (value disk-cache v-pointer index &optional immediate?)
  1126.   (setf (read-pointer
  1127.          disk-cache
  1128.          (addr+ disk-cache v-pointer (+ (ash index 2) $v_data))
  1129.          immediate?)
  1130.         value))
  1131.  
  1132. (defun dc-%simple-vector-length (disk-cache pointer)
  1133.   (the fixnum (ash (the fixnum (read-low-24-bits
  1134.                                 disk-cache (+ pointer $v_log)))
  1135.                    -2)))
  1136.  
  1137. (defun dc-%vector-subtype (disk-cache pointer)
  1138.   (read-8-bits disk-cache (+ pointer $v_subtype)))
  1139.  
  1140. (def-accessor ccl::%vect-subtype (p) (disk-cache pointer)
  1141.   (values (dc-%vector-subtype disk-cache pointer) t))
  1142.  
  1143. (defun dc-read-fixnum (disk-cache address &optional (address-name address))
  1144.   (multiple-value-bind (value imm?) (read-pointer disk-cache address)
  1145.     (unless (and imm? (fixnump value))
  1146.       (error "Inconsistency: pointer at ~s was not a fixnum." address-name))
  1147.     value))
  1148.  
  1149. (defun dc-read-cons (disk-cache address &optional (address-name address))
  1150.   (multiple-value-bind (value imm?) (read-pointer disk-cache address)
  1151.     (unless (and (not imm?) (pointer-tagp value $t_cons))
  1152.       (error "Inconsistency: pointer at ~s was not a cons." address-name))
  1153.     value))
  1154.  
  1155. (defun dc-%svref-fixnum (disk-cache vector index &optional (address-name index))
  1156.   (multiple-value-bind (value imm?) (dc-%svref disk-cache vector index)
  1157.     (unless (and imm? (fixnump value))
  1158.       (error "Inconsistency: pointer at ~s was not a fixnum." address-name))
  1159.     value))
  1160.  
  1161. (def-accessor car (p) (disk-cache pointer)
  1162.   (require-satisfies dc-listp disk-cache pointer)
  1163.   (if (eq pointer $pheap-nil)
  1164.     $pheap-nil
  1165.     (read-pointer disk-cache (- pointer $t_cons))))
  1166.  
  1167. (def-accessor cdr (p) (disk-cache pointer)
  1168.   (require-satisfies dc-listp disk-cache pointer)
  1169.   (if (eq pointer $pheap-nil)
  1170.     $pheap-nil
  1171.     (read-pointer disk-cache pointer)))
  1172.  
  1173. (defun (setf p-car) (value p)
  1174.   (if (pptr-p p)
  1175.     (let ((pheap (pptr-pheap p)))
  1176.       (multiple-value-bind (v imm?) (%p-store pheap value)
  1177.         (setf (dc-car (pheap-disk-cache pheap)
  1178.                       (pptr-pointer p)
  1179.                       imm?)
  1180.               v)
  1181.         (if imm?
  1182.           v
  1183.           (pptr pheap v))))
  1184.     (setf (p-car p) value)))
  1185.  
  1186. (defun (setf dc-car) (value disk-cache pointer &optional immediate?)
  1187.   (require-satisfies dc-consp disk-cache pointer)
  1188.   (setf (read-pointer disk-cache (- pointer $t_cons) immediate?) value))
  1189.  
  1190. (defun (setf p-cdr) (value p)
  1191.   (if (pptr-p p)
  1192.     (let ((pheap (pptr-pheap p)))
  1193.       (multiple-value-bind (v imm?) (%p-store pheap value)
  1194.         (setf (dc-cdr (pheap-disk-cache pheap)
  1195.                       (pptr-pointer p)
  1196.                       imm?)
  1197.               v)
  1198.         (if imm?
  1199.           v
  1200.           (pptr pheap v))))
  1201.     (setf (p-car p) value)))
  1202.  
  1203. (defun (setf dc-cdr) (value disk-cache pointer &optional immediate?)
  1204.   (require-satisfies dc-consp disk-cache pointer)
  1205.   (setf (read-pointer disk-cache pointer immediate?) value))
  1206.  
  1207. (eval-when (:compile-toplevel :execute)
  1208.  
  1209. (defmacro def-cxrs (max-length)
  1210.   (let ((res nil)
  1211.         (prev '("A" "D"))
  1212.         (prev-symbols '(dc-car dc-cdr))
  1213.         (len 2)
  1214.         next next-symbols)
  1215.     (loop
  1216.       (loop for middle in prev
  1217.             for sym in prev-symbols
  1218.             do (loop for prefix in '("A" "D")
  1219.                      for prefix-symbol in '(dc-car dc-cdr)
  1220.                      for new-middle = (concatenate 'string prefix middle)
  1221.                      for name = (intern (concatenate 'string "C" new-middle "R")
  1222.                                         :wood)
  1223.                      for dc-name = (intern (concatenate 'string "DC-" (symbol-name name))
  1224.                                            :wood)
  1225.                      for p-name = (intern (concatenate 'string "P-" (symbol-name name))
  1226.                                           :wood)
  1227.                      for form = `(def-accessor ,name (p) (disk-cache pointer)
  1228.                                    (multiple-value-bind (thing imm?)
  1229.                                                         (,sym disk-cache pointer)
  1230.                                      (when imm?
  1231.                                        (error "Immediate returned from:~@
  1232.                                                (~s ~s #x~x).~@
  1233.                                                Expected a cons pointer."
  1234.                                               ',sym disk-cache pointer))
  1235.                                      (,prefix-symbol disk-cache thing)))
  1236.                      for p-setter = `(defun (setf ,p-name) (value p)
  1237.                                        (if (pptr-p p)
  1238.                                          (let ((pheap (pptr-pheap p)))
  1239.                                            (multiple-value-bind (v imm?) (%p-store pheap value)
  1240.                                              (setf (,dc-name (pheap-disk-cache pheap)
  1241.                                                              (pptr-pointer p)
  1242.                                                              imm?)
  1243.                                                    v)
  1244.                                              (if imm? v (pptr pheap v))))
  1245.                                          (setf (,name p) value)))
  1246.                      for dc-setter = `(defun (setf ,dc-name) (value disk-cache pointer &optional
  1247.                                                                     value-imm?)
  1248.                                         (multiple-value-bind (cons cons-imm?) (,sym disk-cache pointer)
  1249.                                           (when cons-imm?
  1250.                                             (error "(~s ~s ~s) is an immediate."
  1251.                                                    ',sym disk-cache pointer))
  1252.                                           (setf (,prefix-symbol disk-cache cons value-imm?) value)))
  1253.                                         
  1254.                      do
  1255.                      (push form res)
  1256.                      (push p-setter res)
  1257.                      (push dc-setter res)
  1258.                      (push new-middle next)
  1259.                      (push dc-name next-symbols)))
  1260.       (setq prev next prev-symbols next-symbols
  1261.             next nil next-symbols nil)
  1262.       (when (> (incf len) max-length) (return)))
  1263.     `(progn ,@(nreverse res))))
  1264.  
  1265. )
  1266.  
  1267. (def-cxrs 4)
  1268.  
  1269. (def-accessor uvsize (p) (disk-cache pointer)
  1270.   (require-satisfies dc-uvectorp disk-cache pointer)
  1271.   (let ((subtype (dc-%vector-subtype disk-cache pointer)))
  1272.     (dc-uv-subtype-size subtype
  1273.                         (dc-%vector-size disk-cache pointer)
  1274.                         (if (eql $v_bitv subtype)
  1275.                           (read-8-bits disk-cache (addr+ disk-cache pointer $v_data))))))
  1276.  
  1277. (defun dc-uv-subtype-size (subtype bytes &optional last-byte-bits)
  1278.   (let* ((bytes-per-element (svref *subtype->bytes-per-element* subtype)))
  1279.     (values
  1280.      (if bytes-per-element
  1281.        (/ bytes bytes-per-element)
  1282.        (if (eql $v_bitv subtype)
  1283.          (+ (* 8 (- bytes 2)) last-byte-bits)
  1284.          (error "~s not supported for vectors of subtype ~s" 'dc-uvref subtype)))
  1285.      t)))
  1286.       
  1287. (defparameter *subtype->uvreffer*
  1288.   #(nil                                 ; 0 - unused
  1289.     uvref-unsigned-word                 ; 1 - $v_bignum
  1290.     nil                                 ; 2 - $v_macptr - not supported
  1291.     uvref-unsigned-long                 ; 3 - $v_badptr
  1292.     uvref-unsigned-word                 ; 4 - $v_nlfunv
  1293.     nil                                 ; 5 - unused
  1294.     nil                                 ; 6 - unused
  1295.     uvref-unsigned-byte                 ; 7 - $v_ubytev - unsigned byte vector
  1296.     uvref-unsigned-word                 ; 8 - $v_uwordv - unsigned word vector
  1297.     uvref-dfloat                        ; 9 - $v_floatv - float vector
  1298.     uvref-signed-long                   ; 10 - $v_slongv - Signed long vector
  1299.     uvref-unsigned-long                 ; 11 - $v_ulongv - Unsigned long vector
  1300.     uvref-bit-vector                    ; 12 - $v_bitv - Bit vector
  1301.     uvref-signed-byte                   ; 13 - $v_sbytev - Signed byte vector
  1302.     uvref-signed-word                   ; 14 - $v_swordv - Signed word vector
  1303.     uvref-string                        ; 15 - $v_sstr - simple string
  1304.     uvref-genv                          ; 16 - $v_genv - simple general vector
  1305.     uvref-genv                          ; 17 - $v_arrayh - complex array header
  1306.     uvref-genv                          ; 18 - $v_struct - structure
  1307.     nil                                 ; 19 - $v_mark - buffer mark unimplemented
  1308.     uvref-genv                          ; 20 - $v_pkg
  1309.     nil                                 ; 21 - unused
  1310.     uvref-genv                          ; 22 - $v_istruct - type in first element
  1311.     uvref-genv                          ; 23 - $v_ratio
  1312.     uvref-genv                          ; 24 - $v_complex
  1313.     uvref-genv                          ; 25 - $v_instance - clos instance
  1314.     nil                                 ; 26 - unused
  1315.     nil                                 ; 27 - unused
  1316.     nil                                 ; 28 - unused
  1317.     uvref-genv                          ; 29 - $v_weakh - weak list header
  1318.     uvref-genv                          ; 30 - $v_poolfreelist - free pool header
  1319.     uvref-genv                          ; 31 - $v_nhash
  1320.     ; WOOD specific subtypes
  1321.     uvref-genv                          ; 32 - $v_area - area descriptor
  1322.     uvref-genv                          ; 33 - $v_segment - area segment
  1323.     uvref-unsigned-byte                 ; 34 - $v_random-bits - vectors of random bits, e.g. resources
  1324.     uvref-genv                          ; 35 - $v_dbheader - database header
  1325.     nil                                 ; 36 - $v_segment-headers - specially allocated
  1326.     uvref-genv                          ; 37 - $v_btree
  1327.     nil                                 ; 38 - $v_btree-node - specially allocated
  1328.     uvref-genv                          ; 39 - $v_class
  1329.     ))
  1330.  
  1331. (def-accessor uvref (v index) (disk-cache v-pointer)
  1332.   (require-satisfies dc-uvectorp disk-cache v-pointer)
  1333.   (let* ((subtype (dc-%vector-subtype disk-cache v-pointer))
  1334.          (uvreffer (svref *subtype->uvreffer* subtype)))
  1335.     (unless uvreffer
  1336.       (error "~s not valid for vector ~s of subtype ~s"
  1337.              'dc-uvref (dc-pointer-pptr disk-cache v-pointer) subtype))
  1338.     (funcall uvreffer disk-cache v-pointer index)))
  1339.  
  1340. (defun do-uvref (disk-cache pointer offset index reader)
  1341.   (let ((size (dc-%vector-size disk-cache pointer)))
  1342.     (unless (< -1 offset size)
  1343.       (error "Index ~s out of range for ~s"
  1344.              index (dc-pointer-pptr disk-cache pointer)))
  1345.     (funcall reader disk-cache (addr+ disk-cache pointer (+ $v_data offset)))))
  1346.  
  1347. (defun uvref-signed-byte (disk-cache pointer index)
  1348.   (values (do-uvref disk-cache pointer index index 'read-8-bits-signed)
  1349.           t))
  1350.  
  1351. (defun uvref-unsigned-byte (disk-cache pointer index)
  1352.   (values (do-uvref disk-cache pointer index index 'read-8-bits)
  1353.           t))
  1354.  
  1355. (defun uvref-signed-word (disk-cache pointer index)
  1356.   (values (do-uvref disk-cache pointer (* 2 index) index 'read-word)
  1357.           t))
  1358.  
  1359. (defun uvref-unsigned-word (disk-cache pointer index)
  1360.   (values (do-uvref disk-cache pointer (* 2 index) index 'read-unsigned-word)
  1361.           t))
  1362.  
  1363. (defun uvref-signed-long (disk-cache pointer index)
  1364.   (values (do-uvref disk-cache pointer (* 4 index) index 'read-long)
  1365.           t))
  1366.  
  1367. (defun uvref-unsigned-long (disk-cache pointer index)
  1368.   (values (do-uvref disk-cache pointer (* 4 index) index 'read-unsigned-long)
  1369.           t))
  1370.  
  1371. (defun uvref-genv (disk-cache pointer index)
  1372.   (do-uvref disk-cache pointer (* 4 index) index 'read-pointer))
  1373.  
  1374. (defun uvref-string (disk-cache pointer index)
  1375.   (values (code-char (do-uvref disk-cache pointer index index 'read-8-bits))
  1376.           t))
  1377.  
  1378. ; This will get much less ugly when we can stack cons float vectors.
  1379. (defun uvref-dfloat (disk-cache pointer index)
  1380.   (let ((offset (* index 8))
  1381.         (size (dc-%vector-size disk-cache pointer)))
  1382.     (unless (< -1 offset size)
  1383.       (error "Index ~s out of range for ~s"
  1384.              index (dc-pointer-pptr disk-cache pointer)))
  1385.     (values (read-double-float disk-cache (addr+ disk-cache pointer (+ $v_data offset))) t)))
  1386.  
  1387. (defun %bit-vector-index-address-and-bit (disk-cache pointer index)
  1388.   (let ((size (dc-uv-subtype-size
  1389.                $v_bitv
  1390.                (dc-%vector-size disk-cache pointer)
  1391.                (read-8-bits disk-cache (addr+ disk-cache pointer $v_data)))))
  1392.     (unless (< -1 index size)
  1393.       (error "Index ~s out of range for ~s" index (dc-pointer-pptr disk-cache pointer)))
  1394.     (values (addr+ disk-cache pointer (+ $v_data 1 (ash index -3)))
  1395.             (- 7 (logand index 7)))))
  1396.  
  1397. (defun uvref-bit-vector (disk-cache pointer index)
  1398.   (multiple-value-bind (address bit)
  1399.                        (%bit-vector-index-address-and-bit disk-cache pointer index)
  1400.     (values
  1401.      (if (logbitp bit (read-8-bits disk-cache address))
  1402.        1
  1403.        0)
  1404.      t)))
  1405.              
  1406.  
  1407. (defparameter *subtype->uvsetter*
  1408.   #(nil                                 ; 0 - unused
  1409.     uvset-word                          ; 1 - $v_bignum
  1410.     nil                                 ; 2 - $v_macptr - not supported
  1411.     uvset-long                          ; 3 - $v_badptr
  1412.     uvset-word                          ; 4 - $v_nlfunv
  1413.     nil                                 ; 5 - unused
  1414.     nil                                 ; 6 - unused
  1415.     uvset-byte                          ; 7 - $v_ubytev - unsigned byte vector
  1416.     uvset-word                          ; 8 - $v_uwordv - unsigned word vector
  1417.     uvset-dfloat                        ; 9 - $v_floatv - float vector
  1418.     uvset-long                          ; 10 - $v_slongv - Signed long vector
  1419.     uvset-long                          ; 11 - $v_ulongv - Unsigned long vector
  1420.     uvset-bit-vector                    ; 12 - $v_bitv - Bit vector
  1421.     uvset-byte                          ; 13 - $v_sbytev - Signed byte vector
  1422.     uvset-word                          ; 14 - $v_swordv - Signed word vector
  1423.     uvset-string                        ; 15 - $v_sstr - simple string
  1424.     uvset-genv                          ; 16 - $v_genv - simple general vector
  1425.     uvset-genv                          ; 17 - $v_arrayh - complex array header
  1426.     uvset-genv                          ; 18 - $v_struct - structure
  1427.     nil                                 ; 19 - $v_mark - buffer mark unimplemented
  1428.     uvset-genv                          ; 20 - $v_pkg
  1429.     nil                                 ; 21 - unused
  1430.     uvset-genv                          ; 22 - $v_istruct - type in first element
  1431.     uvset-genv                          ; 23 - $v_ratio
  1432.     uvset-genv                          ; 24 - $v_complex
  1433.     uvset-genv                          ; 25 - $v_instance - clos instance
  1434.     nil                                 ; 26 - unused
  1435.     nil                                 ; 27 - unused
  1436.     nil                                 ; 28 - unused
  1437.     uvset-genv                          ; 29 - $v_weakh - weak list header
  1438.     uvset-genv                          ; 30 - $v_poolfreelist - free pool header
  1439.     uvset-genv                          ; 31 - $v_nhash
  1440.     ; WOOD specific subtypes
  1441.     uvset-genv                          ; 32 - $v_area - area descriptor
  1442.     uvset-genv                          ; 33 - $v_segment - area segment
  1443.     uvset-byte                          ; 34 - $v_random-bits - vectors of random bits, e.g. resources
  1444.     uvset-genv                          ; 35 - $v_dbheader - database header
  1445.     nil                                 ; 36 - $v_segment-headers - specially allocated
  1446.     uvset-genv                          ; 37 - $v_btree
  1447.     nil                                 ; 38 - $v_btree-node - specially allocated
  1448.     uvset-genv                          ; 39 - $v_class
  1449.     ))
  1450.  
  1451. (defun (setf p-uvref) (value pptr index)
  1452.   (if (pptr-p pptr)
  1453.     (let ((pheap (pptr-pheap pptr)))
  1454.       (multiple-value-bind (value-pointer imm?)
  1455.                            (if (and (or (bignump value) (typep value 'double-float))
  1456.                                     (memq (svref *subtype->uvsetter* (p-%vect-subtype pptr))
  1457.                                           '(uvset-long uvset-dfloat)))
  1458.                               (values value t)
  1459.                               (%p-store pheap value))
  1460.         (setf (dc-uvref (pheap-disk-cache pheap)
  1461.                         (pptr-pointer pptr)
  1462.                         index
  1463.                         imm?)
  1464.               value-pointer)
  1465.         (if imm?
  1466.           value-pointer
  1467.           (pptr pheap value-pointer))))
  1468.     (setf (uvref pptr index) value)))
  1469.  
  1470. (defun (setf dc-uvref) (value disk-cache pointer index &optional immediate?)
  1471.   (let* ((subtype (dc-%vector-subtype disk-cache pointer))
  1472.          (uvsetter (svref *subtype->uvsetter* subtype)))
  1473.     (unless uvsetter
  1474.       (error "~s not valid for vector ~s of subtype ~s"
  1475.              'dc-uvref (dc-pointer-pptr disk-cache pointer) subtype))
  1476.     (funcall uvsetter value disk-cache pointer index immediate?)))
  1477.  
  1478. (defun do-uvset (value disk-cache pointer offset index writer immediate?)
  1479.   (let ((size (dc-%vector-size disk-cache pointer)))
  1480.     (unless (< -1 offset size)
  1481.       (error "Index ~s out of range for ~s"
  1482.              index (dc-pointer-pptr disk-cache pointer)))
  1483.     (if immediate?
  1484.       (values (funcall writer
  1485.                        value disk-cache (addr+ disk-cache pointer (+ $v_data offset)) t)
  1486.               t)
  1487.       (funcall writer value disk-cache (addr+ disk-cache pointer (+ $v_data offset))))))
  1488.  
  1489. (defun uvset-byte (value disk-cache pointer index immediate?)
  1490.   (unless (and immediate? (fixnump value))
  1491.     (error "Attempt to write a non-fixnum byte"))
  1492.   (do-uvset value disk-cache pointer index index #'(setf read-8-bits) nil))
  1493.  
  1494. (defun uvset-word (value disk-cache pointer index immediate?)
  1495.   (unless (and immediate? (fixnump value))
  1496.     (error "Attempt to write a non-fixnum word"))
  1497.   (do-uvset value disk-cache pointer (* 2 index) index #'(setf read-word) nil))
  1498.  
  1499. (defun uvset-long (value disk-cache pointer index immediate?)
  1500.   (unless immediate?
  1501.     (setq value (require-type
  1502.                  (pointer-load (disk-cache-pheap disk-cache) value :default disk-cache)
  1503.                  'integer)))
  1504.   (do-uvset value disk-cache pointer (* 4 index) index #'(setf read-long) nil))
  1505.  
  1506. (defun uvset-genv (value disk-cache pointer index immediate?)
  1507.   (do-uvset value disk-cache pointer (* 4 index) index #'(setf read-pointer) immediate?))
  1508.  
  1509. (defun uvset-string (value disk-cache pointer index immediate?)
  1510.   (declare (ignore immediate?))
  1511.   (do-uvset (char-code value) disk-cache pointer index index #'(setf read-8-bits) nil))
  1512.  
  1513. (defun uvset-dfloat (value disk-cache pointer index immediate?)
  1514.   (let ((offset (* index 8))
  1515.         (size (dc-%vector-size disk-cache pointer)))
  1516.     (unless (< -1 offset size)
  1517.       (error "Index ~s out of range for ~s"
  1518.              offset (dc-pointer-pptr disk-cache pointer)))
  1519.     (if immediate?
  1520.       (setf (read-double-float disk-cache (addr+ disk-cache pointer (+ $v_data offset)))
  1521.             (require-type value 'double-float))
  1522.       (let ((buf (make-string 8)))
  1523.         (declare (dynamic-extent buf))
  1524.         (require-satisfies pointer-tagp value $t_dfloat)
  1525.         (load-byte-array disk-cache (- value $t_dfloat) 8 buf)
  1526.         (store-byte-array buf disk-cache (addr+ disk-cache pointer (+ $v_data offset)) 8)
  1527.         value))))        
  1528.  
  1529. (defun uvset-bit-vector (value disk-cache pointer index immediate?)
  1530.   (multiple-value-bind (address bit)
  1531.                        (%bit-vector-index-address-and-bit disk-cache pointer index)
  1532.     (unless (and immediate? (or (eql value 1) (eql value 0)))
  1533.       (error "bit vector value must be 0 or 1"))
  1534.     (let* ((byte (read-8-bits disk-cache address))
  1535.            (set? (logbitp bit byte)))
  1536.       (if (eql  value 0)
  1537.         (when set?
  1538.           (setf (read-8-bits disk-cache address)
  1539.                 (logand byte (lognot (ash 1 bit)))))
  1540.         (unless set?
  1541.           (setf (read-8-bits disk-cache address)
  1542.                 (logior byte (ash 1 bit)))))))
  1543.   value)
  1544.  
  1545. (defun p-array-data-and-offset (p)
  1546.   (if (pptr-p p)
  1547.     (let ((pheap (pptr-pheap p)))
  1548.       (multiple-value-bind (address offset)
  1549.                            (dc-array-data-and-offset (pheap-disk-cache pheap)
  1550.                                                      (pptr-pointer p))
  1551.         (values (pptr pheap address) offset)))
  1552.     (ccl::array-data-and-offset p)))
  1553.  
  1554. (defun dc-array-data-and-offset (disk-cache pointer)
  1555.   (require-satisfies dc-arrayp disk-cache pointer)
  1556.   (if (not (dc-vector-subtype-p disk-cache pointer $v_arrayh))
  1557.     (values pointer 0)
  1558.     (let* ((p pointer)
  1559.            (offset 0))
  1560.       (loop
  1561.         (incf offset (dc-%svref-fixnum disk-cache p $arh.offs '$arh.offs))
  1562.         (let ((next-p (dc-%svref disk-cache p $arh.vect)))
  1563.           (unless (logbitp $arh_disp_bit (dc-%arrayh-bits disk-cache p))
  1564.             (return (values next-p offset)))
  1565.           (setq p next-p))))))
  1566.  
  1567. (def-accessor length (p) (disk-cache pointer)
  1568.   (values
  1569.    (cond ((dc-listp disk-cache pointer)
  1570.           (dc-%length-of-list disk-cache pointer))
  1571.          ((dc-vectorp disk-cache pointer)
  1572.           (dc-%vector-length disk-cache pointer))
  1573.          (t (error "~s is neither a list nor a vector"
  1574.                    (dc-pointer-pptr disk-cache pointer))))
  1575.    t))
  1576.  
  1577. (defun dc-%vector-length (disk-cache pointer)
  1578.   (if (eql $v_arrayh (dc-%vector-subtype disk-cache pointer))
  1579.     (if (logbitp $arh_fill_bit (dc-%arrayh-bits disk-cache pointer))
  1580.       (dc-%svref disk-cache pointer $arh.fill)
  1581.       (dc-%svref disk-cache pointer $arh.vlen))
  1582.     (dc-uvsize disk-cache pointer)))
  1583.  
  1584. (defun dc-%length-of-list (disk-cache pointer)
  1585.   (let ((len 0))
  1586.     (loop
  1587.       (if (eql $pheap-nil pointer)
  1588.         (return len))
  1589.       (setq pointer (dc-cdr disk-cache pointer))
  1590.       (incf len))))
  1591.   
  1592. (def-accessor symbol-name (p) (disk-cache pointer)
  1593.   (require-satisfies dc-symbolp disk-cache pointer)
  1594.   (read-pointer disk-cache (+ pointer $sym_pname)))
  1595.  
  1596. (def-accessor symbol-package (p) (disk-cache pointer)
  1597.   (require-satisfies dc-symbolp disk-cache pointer)
  1598.   (read-pointer disk-cache (+ pointer $sym_package)))
  1599.  
  1600. (defun dc-error (string disk-cache pointer)
  1601.   (let ((p (dc-pointer-pptr disk-cache pointer)))
  1602.     (error string p (p-load p))))
  1603.  
  1604. (def-accessor symbol-value (p) (disk-cache pointer)
  1605.   (let ((values (dc-symbol-values-list disk-cache pointer)))
  1606.     (let ((value (ccl::%unbound-marker-8))
  1607.           (value-imm? t))
  1608.       (when values
  1609.         (multiple-value-setq (value value-imm?) (dc-car disk-cache values)))
  1610.       (when (and value-imm? (eq value (ccl::%unbound-marker-8)))
  1611.         (dc-error "Unbound variable: ~s = ~s" disk-cache pointer))
  1612.       (values value value-imm?))))
  1613.  
  1614. ; Should probably take an area parameter
  1615. (defun dc-symbol-values-list (disk-cache pointer &optional create?)
  1616.   (require-satisfies dc-symbolp disk-cache pointer)
  1617.   (multiple-value-bind (values vv-imm?)
  1618.                        (read-pointer disk-cache (+ pointer $sym_values))
  1619.     (when (or vv-imm? (not (dc-listp disk-cache values)))
  1620.       (dc-error "Bad value list for symbol: ~s = ~s" disk-cache pointer))
  1621.     (if (eq values $pheap-nil)
  1622.       (when create?
  1623.         (setf (read-pointer disk-cache (+ pointer $sym_values))
  1624.               (dc-make-list disk-cache 2)))
  1625.       values)))  
  1626.  
  1627. (defun (setf p-symbol-value) (value symbol)
  1628.   (if (pptr-p symbol)
  1629.     (let ((pheap (pptr-pheap symbol)))
  1630.       (multiple-value-bind (v v-imm?) (%p-store pheap value)
  1631.         (setf (dc-symbol-value (pheap-disk-cache pheap) (pptr-pointer symbol) v-imm?)
  1632.               v)
  1633.         (if v-imm? v (pptr pheap v))))
  1634.     (setf (symbol-value symbol) value)))
  1635.  
  1636. (defun (setf dc-symbol-value) (value disk-cache pointer &optional imm?)
  1637.   (let ((values (dc-symbol-values-list disk-cache pointer t)))
  1638.     (setf (dc-car disk-cache values imm?) value)
  1639.     (values value imm?)))
  1640.   
  1641. (defun dc-pkg-arg (disk-cache pkg &optional (pkg-imm? (not (integerp pkg))))
  1642.   (or (dc-find-package disk-cache pkg pkg-imm?)
  1643.       (error "There is no package named ~s"
  1644.              (dc-canonicalize-pkg-arg disk-cache pkg pkg-imm?))))
  1645.  
  1646. (def-accessor package-name (p) (disk-cache pointer)
  1647.   (dc-car disk-cache
  1648.           (dc-%svref disk-cache (dc-pkg-arg disk-cache pointer) $pkg.names)))
  1649.  
  1650. (def-accessor package-nicknames (p) (disk-cache pointer)
  1651.   (dc-cdr disk-cache
  1652.           (dc-%svref disk-cache (dc-pkg-arg disk-cache pointer) $pkg.names)))
  1653.  
  1654. (def-accessor string (p) (disk-cache pointer)
  1655.   (if (dc-stringp disk-cache pointer)
  1656.     pointer
  1657.     (dc-symbol-name disk-cache pointer)))
  1658.  
  1659. (def-accessor array-rank (p) (disk-cache pointer)
  1660.   (require-satisfies dc-arrayp disk-cache pointer)
  1661.   (values
  1662.    (if (dc-vectorp disk-cache pointer)
  1663.      1
  1664.      (ash (dc-%arrayh-rank4 disk-cache pointer) -2))
  1665.    t))
  1666.  
  1667. (def-accessor array-dimension (p n) (disk-cache pointer)
  1668.   (let ((rank (dc-array-rank disk-cache pointer)))
  1669.     (if (or (not (fixnump n)) (< n 0) (>= n rank))
  1670.       (error "~s is non-integer, < 0, or > rank of ~s"
  1671.              n (dc-pointer-pptr disk-cache pointer))
  1672.       (if (eql 1 rank)
  1673.         (dc-%vector-length disk-cache pointer)
  1674.         (dc-%svref-fixnum disk-cache pointer (+ $arh.dims n))))))
  1675.  
  1676. (def-accessor array-dimensions (p) (disk-cache pointer)
  1677.   (let ((rank (dc-array-rank disk-cache pointer)))
  1678.     (declare (fixnum rank))
  1679.     (if (eql 1 rank)
  1680.       (values (list (dc-%vector-length disk-cache pointer)) t)
  1681.       (let ((res nil)
  1682.             (index $arh.dims))
  1683.         (declare (fixnum index))
  1684.         (dotimes (i rank)
  1685.           (push (dc-%svref-fixnum disk-cache pointer index) res)
  1686.           (incf index))
  1687.         (values
  1688.          (nreverse res)
  1689.          t)))))
  1690.   
  1691. (defun p-aref (p &rest indices)
  1692.   (declare (dynamic-extent indices))
  1693.   (if (pptr-p p)
  1694.     (let ((pheap (pptr-pheap p)))
  1695.       (multiple-value-bind (res imm?) (dc-aref-internal (pheap-disk-cache pheap)
  1696.                                                         (pptr-pointer p)
  1697.                                                         indices)
  1698.         (if imm?
  1699.           res
  1700.           (pptr pheap res))))
  1701.     (apply #'aref p indices)))
  1702.  
  1703. (defun dc-aref (disk-cache pointer &rest indices)
  1704.   (declare (dynamic-extent indices))
  1705.   (dc-aref-internal disk-cache pointer indices))
  1706.  
  1707. ; Clobbers the indices arg. It is a stack-consed rest arg in my uses of it here.
  1708. (defun dc-aref-internal (disk-cache pointer indices)
  1709.   (multiple-value-bind (vector index) (dc-aref-vector-and-index disk-cache pointer indices)
  1710.     (if (null vector)                   ; rank 0
  1711.       nil
  1712.       (dc-uvref disk-cache vector index))))
  1713.  
  1714. (defun dc-aref-vector-and-index (disk-cache pointer indices)
  1715.   (let ((rank (dc-array-rank disk-cache pointer)))
  1716.     (declare (fixnum rank))
  1717.     (unless (eql rank (length indices))
  1718.       (error "~s cannot be accessed with ~s subscripts."
  1719.              (dc-pointer-pptr disk-cache pointer)
  1720.              (length indices)))
  1721.     (if (eql rank 0)
  1722.       nil
  1723.       (multiple-value-bind (vector offset) (dc-array-data-and-offset disk-cache pointer)
  1724.         (if (eql rank 1)
  1725.           (values vector (+ offset (car indices)))
  1726.           (let* ((arrayh-index (+ $arh.dims rank -1))
  1727.                  (index 0)
  1728.                  (rest-size 1))
  1729.             (declare (fixnum index))
  1730.             (setq indices (nreverse indices))
  1731.             (dotimes (i rank)
  1732.               (let ((idx (pop indices))
  1733.                     (dim (dc-%svref-fixnum disk-cache pointer arrayh-index)))
  1734.                 (if (>= idx dim)
  1735.                   (error "Array index ~s out of bounds for ~s"
  1736.                          idx (dc-pointer-pptr disk-cache pointer)))
  1737.                 (setq index (+ index (* idx rest-size)))
  1738.                 (setq rest-size (* rest-size dim))
  1739.                 (decf arrayh-index)))
  1740.             (values vector (+ offset index))))))))
  1741.  
  1742. (defun (setf p-aref) (value p &rest indices)
  1743.   (declare (dynamic-extent indices))
  1744.   (if (pptr-p p)
  1745.     (let ((pheap (pptr-pheap p)))
  1746.       (multiple-value-bind (v imm?) (%p-store pheap value)
  1747.         (dc-setf-aref (pheap-disk-cache pheap) (pptr-pointer p) v imm? indices)
  1748.         (if imm?
  1749.           v
  1750.           (pptr pheap v))))
  1751.     (setf (apply #'aref p indices) value)))
  1752.                     
  1753. (defun dc-setf-aref (disk-cache pointer value value-imm? indices)
  1754.   (multiple-value-bind (vector index) (dc-aref-vector-and-index disk-cache pointer indices)
  1755.     (setf (dc-uvref disk-cache vector index value-imm?) value)))
  1756.  
  1757. #|
  1758. (defun incf-index-list (indices dims)
  1759.   (do ((indices-tail indices (cdr indices-tail))
  1760.        (dims-tail dims (cdr dims-tail)))
  1761.       ((null indices-tail) (return nil))
  1762.     (if (>= (incf (car indices-tail)) (car dims-tail))
  1763.       (setf (car indices-tail) 0)
  1764.       (return indices))))
  1765.  
  1766. (defun p-fill-array (array)
  1767.   (let* ((dims (p-array-dimensions array))
  1768.          (indices (make-list (length dims) :initial-element 0)))
  1769.     (loop
  1770.       (let ((value (p-store (pptr-pheap array) indices nil)))
  1771.         (apply #'(setf p-aref) value array indices))
  1772.       (unless (incf-index-list indices dims)
  1773.         (return array)))))
  1774.  
  1775. (defun p-check-array (array)
  1776.   (let* ((dims (p-array-dimensions array))
  1777.          (indices (make-list (length dims) :initial-element 0)))
  1778.     (loop
  1779.       (let ((value (p-load (apply #'p-aref array indices) t)))
  1780.         (unless (equal value indices)
  1781.           (cerror "Continue."
  1782.                   "~&SB: ~s, WAS: ~s~%" indices value))
  1783.         (unless (incf-index-list indices dims)
  1784.           (return))))))
  1785.  
  1786. |#
  1787.  
  1788. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  1789. ;;
  1790. ;; Consers
  1791. ;;
  1792.  
  1793. (defparameter *subtype-initial-element*
  1794.   #(nil                                 ; 0 - unused
  1795.     nil                                 ; 1 - $v_bignum
  1796.     nil                                 ; 2 - $v_macptr not implemented
  1797.     nil                                 ; 3 - $v_badptr not implemented
  1798.     nil                                 ; 4 - $v_nlfunv
  1799.     nil                                 ; 5 - unused
  1800.     nil                                 ; 6 - unused
  1801.     nil                                 ; 7 - $v_ubytev - unsigned byte vector
  1802.     nil                                 ; 8 - $v_uwordv - unsigned word vector
  1803.     0                                   ; 9 - $v_floatv - float vector
  1804.     nil                                 ; 10 - $v_slongv - Signed long vector
  1805.     nil                                 ; 11 - $v_ulongv - Unsigned long vector
  1806.     nil                                 ; 12 - $v_bitv - Bit vector
  1807.     nil                                 ; 13 - $v_sbytev - Signed byte vector
  1808.     nil                                 ; 14 - $v_swordv - Signed word vector
  1809.     nil                                 ; 15 - $v_sstr - simple string
  1810.     #.$pheap-nil                        ; 16 - $v_genv - simple general vector
  1811.     #.$pheap-nil                        ; 17 - $v_arrayh - complex array header
  1812.     #.$pheap-nil                        ; 18 - $v_struct - structure
  1813.     nil                                 ; 19 - $v_mark - buffer mark unimplemented
  1814.     #.$pheap-nil                        ; 20 - $v_pkg
  1815.     nil                                 ; 21 - unused
  1816.     #.$pheap-nil                        ; 22 - $v_istruct - type in first element
  1817.     0                                   ; 23 - $v_ratio
  1818.     0                                   ; 24 - $v_complex
  1819.     #.$pheap-nil                        ; 25 - $v_instance - clos instance
  1820.     nil                                 ; 26 - unused
  1821.     nil                                 ; 27 - unused
  1822.     nil                                 ; 28 - unused
  1823.     #.$pheap-nil                        ; 29 - $v_weakh - weak list header
  1824.     #.$pheap-nil                        ; 30 - $v_poolfreelist - free pool header
  1825.     nil                                 ; 31 - $v_nhash unused
  1826.     #.$pheap-nil                        ; 32 - $v_area - area descriptor
  1827.     #.$pheap-nil                        ; 33 - $v_segment - area segment
  1828.     nil                                 ; 34 - $v_random-bits - vectors of random bits, e.g. resources
  1829.     #.$pheap-nil                        ; 35 - $v_dbheader - database header
  1830.     nil                                 ; 36 - $v_segment-headers - specially allocated
  1831.     #.$pheap-nil                        ; 37 - $v_btree
  1832.     nil                                 ; 38 - $v_btree-node - specially allocated
  1833.     #.$pheap-nil                        ; 39 - $v_class
  1834.     ))
  1835.  
  1836. (defun initialize-vector-storage (disk-cache address length subtype 
  1837.                                              bytes-per-element initial-element
  1838.                                              &optional immediate?)
  1839.   (let* ((ptr address)
  1840.          (length (require-type length 'fixnum))
  1841.          (size (require-type (* length bytes-per-element) 'fixnum))
  1842.          (min-disk-cache-size (addr+ disk-cache ptr (+ size $vector-header-size))))
  1843.     (declare (fixnum length size))
  1844.     (unless (eql 0 (logand 7 ptr))
  1845.       (error "Address ~s not double-word aligned" address))
  1846.     (unless (typep min-disk-cache-size 'fixnum)
  1847.       (error "Attempt to allocate a vector that makes the file too long"))
  1848.     (unless (< size (expt 2 24))
  1849.       (error "size: ~s > 24 bits") length)
  1850.     (extend-disk-cache disk-cache min-disk-cache-size)
  1851.     (unless (or (eql bytes-per-element 8)
  1852.                 (eql bytes-per-element 4)
  1853.                 (eql bytes-per-element 2)
  1854.                 (eql bytes-per-element 1))
  1855.       (error "~s was ~s, should be 1, 2, or 4"
  1856.              'bytes-per-element bytes-per-element))
  1857.     (setf (read-long disk-cache ptr) $vector-header
  1858.           (read-8-bits disk-cache (incf ptr 4)) subtype
  1859.           (read-low-24-bits disk-cache ptr) size)
  1860.     (when initial-element
  1861.       (funcall (case bytes-per-element ((4 8) 'fill-long) (2 'fill-word) (1 'fill-byte))
  1862.                disk-cache
  1863.                (addr+ disk-cache ptr 4)
  1864.                initial-element
  1865.                ; round up to the nearest double word
  1866.                (* (case bytes-per-element ((4 8) 2) (2 4) (1 8))
  1867.                   (ash (+ size 7) -3))
  1868.                immediate?)))
  1869.   (+ (the fixnum address) $t_vector))
  1870.  
  1871. ; All sizes are rounded up to a multiple of 8 bytes.
  1872. (defmacro normalize-size (x &optional (multiple 8))
  1873.   (let ((mask (1- multiple)))
  1874.     `(logand (lognot ,mask) (+ ,x ,mask))))
  1875.  
  1876. (assert (eql $segment-header-entry-bytes
  1877.              (normalize-size $segment-header-entry-bytes)))
  1878.  
  1879. ; Make a new area with single segment.
  1880. (defun p-make-area (pheap &rest rest &key segment-size flags)
  1881.   (declare (ignore segment-size flags))
  1882.   (declare (dynamic-extent rest))
  1883.   (pptr pheap (apply #'dc-make-area (pheap-disk-cache pheap) rest)))
  1884.  
  1885. (defun dc-make-area (disk-cache &key
  1886.                                 (segment-size *default-area-segment-size*)
  1887.                                 (flags 0))
  1888.   (setq segment-size (require-type segment-size 'fixnum)
  1889.         flags (require-type flags 'fixnum))
  1890.   (symbol-macrolet ((area-header-size (normalize-size (* 4 $area-descriptor-size))))
  1891.     (let* ((area (%dc-allocate-new-memory disk-cache 1 $v_area))        ; take 1 page
  1892.            (free-count (floor (- (dc-%vector-size disk-cache area) area-header-size)
  1893.                               $segment-header-entry-bytes))
  1894.            (free-ptr (+ area $v_data area-header-size $t_cons
  1895.                         (- $segment-header-entry-bytes))))
  1896.       (assert (typep free-count 'fixnum))
  1897.       (dc-%svfill disk-cache area
  1898.         $segment-headers.area area
  1899.         ; $segment-headers.link is already $pheap-nil
  1900.         ($area.flags t) flags
  1901.         ($area.segment-size t) segment-size
  1902.         $area.last-headers area
  1903.         ($area.free-count t) free-count
  1904.         $area.free-ptr free-ptr)
  1905.       (dc-cons-segment disk-cache area segment-size $pheap-nil)
  1906.       area)))
  1907.  
  1908. (defmacro with-consing-area (area &body body)
  1909.   (let ((thunk (gensym)))
  1910.     `(flet ((,thunk () ,@body))
  1911.        (declare (dynamic-extend #',thunk))
  1912.        (call-with-consing-area #',thunk ,area))))
  1913.  
  1914. (defun call-with-consing-area (thunk area)
  1915.   (setq area (require-type area 'pptr))
  1916.   (let ((pheap (pptr-pheap area))
  1917.         (pointer (pptr-pointer area)))
  1918.     (require-satisfies dc-vector-subtype-p (pheap-disk-cache pheap) pointer $v_area)
  1919.     (let ((old-area (pheap-consing-area pheap)))
  1920.       (unwind-protect
  1921.         (progn
  1922.           (setf (pheap-consing-area pheap) pointer)
  1923.           (funcall thunk))
  1924.         (setf (pheap-consing-area pheap) old-area)))))
  1925.  
  1926. (def-accessor area (p) (disk-cache pointer)
  1927.   (let* ((page (logand pointer (disk-cache-mask disk-cache)))
  1928.          (segment (read-long disk-cache (+ page $block-segment-ptr))))
  1929.     (dc-%svref disk-cache segment  $segment.area)))
  1930.  
  1931. (defun area (p)
  1932.   (declare (ignore p))
  1933.   (error "In-memory objects do not have an area.."))
  1934.  
  1935.  
  1936. ; Cons a new segment for the given area.
  1937. ; The size defaults to the area's segment-size
  1938. ; The free-link parameter is here only for use by dc-make-area above,
  1939. ; so that it doesn't have to inline this code.
  1940. ; Returns the pointer to the segment header.
  1941. (defun dc-cons-segment (disk-cache area &optional segment-size free-link)
  1942.   (unless segment-size
  1943.     (setq segment-size (dc-%svref disk-cache area $area.segment-size)))
  1944.   (let ((free-count (dc-%svref-fixnum disk-cache area $area.free-count '$area.free-count))
  1945.         (segment (%dc-allocate-new-memory disk-cache segment-size $v_segment))
  1946.         free-ptr)
  1947.     (declare (fixnum free-count))
  1948.     (flet ((get-free-link (disk-cache free-ptr)
  1949.              (if (eql 0 (dc-read-fixnum disk-cache (+ free-ptr $segment-header_freebytes)))
  1950.                (dc-read-cons disk-cache (+ free-ptr $segment-header_free-link)
  1951.                              '$segment-header_free-link)
  1952.                free-ptr)))
  1953.       (if (> free-count 0)
  1954.         (let ((old-free-ptr (dc-%svref disk-cache area $area.free-ptr)))
  1955.           (setq free-ptr (+ old-free-ptr $segment-header-entry-bytes)
  1956.                 free-link (or free-link (get-free-link disk-cache old-free-ptr))
  1957.                 free-count (1- free-count)))
  1958.         (symbol-macrolet ((segment-header-bytes (normalize-size (* 4 $segment-header-size))))
  1959.           (let* ((new-headers (%dc-allocate-new-memory disk-cache 1 $v_segment-headers)))
  1960.             (setf free-ptr (+ new-headers $v_data segment-header-bytes $t_cons)
  1961.                   free-link (or free-link
  1962.                                 (get-free-link disk-cache
  1963.                                                (dc-%svref disk-cache area $area.free-ptr)))
  1964.                   free-count (floor (- (dc-%vector-size disk-cache new-headers)
  1965.                                        segment-header-bytes)
  1966.                                     $segment-header-entry-bytes)
  1967.                   (dc-%svref disk-cache new-headers $segment-headers.area) area
  1968.                   ; $segment-headers.link is already $pheap-nil
  1969.                   (dc-%svref disk-cache 
  1970.                              (dc-%svref disk-cache area $area.last-headers)
  1971.                              $segment-headers.link)
  1972.                   new-headers
  1973.                   (dc-%svref disk-cache area $area.last-headers) new-headers))))
  1974.       (dc-%svfill disk-cache segment
  1975.         $segment.area area
  1976.         $segment.header free-ptr)
  1977.       (symbol-macrolet ((segment-header-bytes (normalize-size (* 4 $segment-header-size))))
  1978.         (setf (read-pointer disk-cache (+ free-ptr $segment-header_free))
  1979.               (+ segment $v_data segment-header-bytes $t_cons)
  1980.               (read-pointer disk-cache (+ free-ptr $segment-header_freebytes) t)
  1981.               (- (dc-%vector-size disk-cache segment) segment-header-bytes)
  1982.               (read-pointer disk-cache (+ free-ptr $segment-header_free-link))
  1983.               free-link
  1984.               (read-pointer disk-cache (+ free-ptr $segment-header_segment))
  1985.               segment))
  1986.       (dc-%svfill disk-cache area
  1987.         ($area.free-count t) free-count
  1988.         $area.free-ptr free-ptr))))
  1989.  
  1990. ; This is where the disk file gets longer.
  1991. ; We grow a segment at a time.
  1992. ; Segments are an even multiple of the page size in length and are aligned on a page
  1993. ; boundary.
  1994. ; This fills in only the vector header word and the subtype & length word.
  1995. ; All other initialization must be done by the caller.
  1996. (defun %dc-allocate-new-memory (disk-cache segment-size subtype
  1997.                                            &optional
  1998.                                            (initial-element $pheap-nil)
  1999.                                            ie-imm?)
  2000.   (let* ((page-size (disk-cache-page-size disk-cache))
  2001.          (page-count (floor (+ segment-size (1- page-size)) page-size)))
  2002.     (setq segment-size (* page-count page-size))
  2003.     (multiple-value-bind (free-page immediate?)
  2004.                          (dc-%svref disk-cache $root-vector $pheap.free-page)
  2005.       (unless (and immediate? (fixnump free-page))
  2006.         (error "Inconsistent PHEAP: free pointer not a fixnum"))
  2007.       (setf (dc-%svref disk-cache $root-vector $pheap.free-page t) 
  2008.             (require-type (+ free-page page-count) 'fixnum))
  2009.       (let* ((free (* free-page page-size))
  2010.              (data-size (- segment-size (* page-count $block-overhead)))
  2011.              (res (initialize-vector-storage
  2012.                    disk-cache (+ free $block-overhead)
  2013.                    (ash (- data-size $vector-header-size) -2)
  2014.                    subtype 4 initial-element ie-imm?)))
  2015.         (incf free $block-segment-ptr)
  2016.         (dotimes (i page-count)
  2017.           (setf (read-pointer disk-cache free) res)
  2018.           (incf free page-size))
  2019.         res))))
  2020.  
  2021. (eval-when (:compile-toplevel :execute)
  2022.   (assert (< (expt 2 24) most-positive-fixnum)))
  2023.  
  2024. (assert (fixnump (1- (expt 2 24))))
  2025.  
  2026. ; And here's where all vectors are consed.
  2027. (defun %cons-vector-in-area (disk-cache area length subtype &optional
  2028.                                         initial-element (immediate? nil))
  2029.   (unless initial-element
  2030.     (setq initial-element (svref *subtype-initial-element* subtype)))
  2031.   (let* ((bytes-per-element (svref *subtype->bytes-per-element* subtype))
  2032.          (size (* length bytes-per-element)))
  2033.     (unless (< size (expt 2 24))
  2034.       (error "Attempt to allocate a vector larger than ~s bytes long"
  2035.              (1- (expt 2 24))))
  2036.     (locally (declare (fixnum size))
  2037.       (let* ((address (%allocate-storage disk-cache area (+ $vector-header-size size))))
  2038.         (initialize-vector-storage
  2039.          disk-cache (- address $t_cons) length subtype bytes-per-element initial-element
  2040.          immediate?)))))
  2041.  
  2042. ; Allocate size bytes of storage from the given area.
  2043. ; Does not write anything in the storage.
  2044. ; If you do not fill it properly, the next GC of the pheap will die a horrible death.
  2045. (defun %allocate-storage (disk-cache area size)
  2046.   (setq area (maybe-default-disk-cache-area disk-cache area))
  2047.   (%allocate-storage-internal
  2048.    disk-cache area (dc-%svref disk-cache area $area.free-ptr) (normalize-size size)))
  2049.  
  2050. ; Do the work for %allocate-storage
  2051. ; Size must be normalized
  2052. (defun %allocate-storage-internal (disk-cache area segment size &optional
  2053.                                               last-free-segment
  2054.                                               (initial-segment segment)
  2055.                                               it-better-fit)
  2056.   (let ((freebytes (dc-read-fixnum disk-cache (+ segment $segment-header_freebytes)
  2057.                                    '$segment-header_freebytes)))
  2058.     (declare (fixnum freebytes))
  2059.     (if (>= freebytes size)
  2060.       ; The allocation fits in this segment
  2061.       (let* ((address (dc-read-cons disk-cache (+ segment $segment-header_free))))
  2062.         (setf (read-pointer disk-cache (+ segment $segment-header_freebytes) t)
  2063.               (decf freebytes size)
  2064.               (read-pointer disk-cache (+ segment $segment-header_free))
  2065.               (addr+ disk-cache address size))
  2066.         (when (and (eql 0 freebytes) last-free-segment)
  2067.           ; This segment is full. Splice it out of the free list.
  2068.           (setf (read-pointer disk-cache (+ last-free-segment $segment-header_free-link))
  2069.                 (dc-read-cons disk-cache (+ segment $segment-header_free-link))
  2070.                 (read-pointer disk-cache (+ segment $segment-header_free-link))
  2071.                 $pheap-nil))
  2072.         address)
  2073.       ; Does not fit in this segment, try next free segment
  2074.       (let ((free-link (dc-read-cons disk-cache (+ segment $segment-header_free-link))))
  2075.         (when it-better-fit
  2076.           (error "it-better-fit and it doesn't"))
  2077.         (if (not (eql free-link $pheap-nil))
  2078.           ; Try the next segment in the free list
  2079.           (%allocate-storage-internal
  2080.            disk-cache area free-link size segment initial-segment)
  2081.           ; Does not fit in any of the existing segments. Make a new one.
  2082.           (let ((new-segment (dc-cons-segment
  2083.                               disk-cache
  2084.                               area
  2085.                               (max
  2086.                                (dc-%svref disk-cache area $area.segment-size)
  2087.                                (addr+
  2088.                                 disk-cache
  2089.                                 (+ $block-overhead
  2090.                                    (normalize-size (* 4 $segment-header-size))
  2091.                                    $vector-header-size)
  2092.                                 size)))))
  2093.             (%allocate-storage-internal
  2094.              disk-cache area new-segment size segment initial-segment t)))))))
  2095.  
  2096. (defun maybe-default-disk-cache-area (disk-cache area)
  2097.   (unless area
  2098.     (setq area (dc-default-consing-area disk-cache)))
  2099.   (require-satisfies dc-vector-subtype-p disk-cache area $v_area)
  2100.   area)
  2101.  
  2102. (defun maybe-default-area (pheap area)
  2103.   (if area
  2104.     (pheap-pptr-pointer area pheap)
  2105.     (pheap-consing-area pheap)))
  2106.  
  2107. (defun p-cons (pheap car cdr &optional area)
  2108.   (multiple-value-bind (car-p car-immediate?) (%p-store pheap car)
  2109.     (multiple-value-bind (cdr-p cdr-immediate?) (%p-store pheap cdr)
  2110.       (pptr pheap
  2111.             (dc-cons (pheap-disk-cache pheap)
  2112.                           car-p cdr-p car-immediate? cdr-immediate?
  2113.                           (maybe-default-area pheap area))))))
  2114.  
  2115. (defun dc-cons (disk-cache car cdr &optional
  2116.                                 car-immediate? cdr-immediate? area)
  2117.   (let ((address (%allocate-storage disk-cache area 8)))
  2118.     (setf (read-pointer disk-cache (- address 4) car-immediate?) car
  2119.           (read-pointer disk-cache address cdr-immediate?) cdr)
  2120.     address))
  2121.  
  2122. (defun p-list (pheap &rest elements)
  2123.   (declare (dynamic-extent elements))
  2124.   (%p-list*-in-area pheap nil elements))
  2125.  
  2126. (defun p-list-in-area (pheap area &rest elements)
  2127.   (declare (dynamic-extent elements))
  2128.   (%p-list*-in-area pheap area elements))
  2129.  
  2130. (defun %p-list*-in-area (pheap area elements)
  2131.   (let* ((disk-cache (pheap-disk-cache pheap))
  2132.          (res $pheap-nil)
  2133.          (area-pointer (maybe-default-area pheap area)))
  2134.     (require-satisfies dc-vector-subtype-p disk-cache area-pointer $v_area)
  2135.     (setq elements (nreverse elements))
  2136.     (dolist (element elements)
  2137.       (multiple-value-bind (car car-imm?) (%p-store pheap element)
  2138.         (setq res (dc-cons disk-cache car res car-imm? nil area-pointer))))
  2139.     (pptr pheap res)))
  2140.  
  2141. (defun p-make-list (pheap size &key initial-element area)
  2142.   (let* ((disk-cache (pheap-disk-cache pheap))
  2143.          (area-pointer (maybe-default-area pheap area)))
  2144.     (require-satisfies dc-vector-subtype-p disk-cache area-pointer $v_area)
  2145.     (multiple-value-bind (ie ie-imm?) (%p-store pheap initial-element)
  2146.       (pptr pheap (dc-make-list disk-cache size ie area ie-imm?)))))
  2147.  
  2148. (defun dc-make-list (disk-cache size &optional ie area ie-imm?)
  2149.   (when (and (null ie) (not ie-imm?))
  2150.     (setq ie $pheap-nil))
  2151.   (let ((res $pheap-nil))
  2152.     (dotimes (i size)
  2153.       (setq res (dc-cons disk-cache ie res ie-imm? nil area)))
  2154.     res))
  2155.  
  2156. (defun p-make-uvector (pheap length subtype &key
  2157.                              (initial-element nil ie?)
  2158.                              area)
  2159.   (let (ie ie-imm?)
  2160.     (when ie?
  2161.       (multiple-value-setq (ie ie-imm?) (%p-store pheap initial-element)))
  2162.     (pptr pheap
  2163.           (dc-make-uvector
  2164.            (pheap-disk-cache pheap)
  2165.            length
  2166.            subtype
  2167.            (maybe-default-area pheap area)
  2168.            ie ie-imm?))))
  2169.  
  2170. (defun dc-make-uvector (disk-cache length &optional
  2171.                                         (subtype $v_genv)
  2172.                                         area
  2173.                                         initial-element
  2174.                                         ie-imm?)
  2175.   (setq area (maybe-default-disk-cache-area disk-cache area))
  2176.   (if (eql subtype $v_bitv)
  2177.     (%cons-bit-vector disk-cache area length initial-element ie-imm?)
  2178.     (progn
  2179.       (if (and (eq subtype $v_sstr) ie-imm?)
  2180.         (setq initial-element (char-code initial-element)))
  2181.       (%cons-vector-in-area disk-cache area length subtype initial-element ie-imm?))))
  2182.  
  2183. (defun p-make-vector (pheap length &key
  2184.                             (initial-element nil ie?)
  2185.                             area)
  2186.   (let (ie ie-imm?)
  2187.     (when ie?
  2188.       (multiple-value-setq (ie ie-imm?) (%p-store pheap initial-element)))
  2189.     (pptr pheap
  2190.           (dc-make-vector
  2191.            (pheap-disk-cache pheap)
  2192.            length
  2193.            (maybe-default-area pheap area)
  2194.            ie ie-imm?))))
  2195.  
  2196. (defun dc-make-vector (disk-cache length &optional
  2197.                                   area
  2198.                                   initial-element
  2199.                                   ie-imm?)
  2200.   (dc-make-uvector disk-cache length $v_genv area initial-element ie-imm?))
  2201.  
  2202. (defun %cons-bit-vector (disk-cache area length &optional initial-element ie-imm?)
  2203.   (let* ((bytes (1+ (ceiling length 8))))
  2204.     (unless (< bytes (expt 2 24))
  2205.       (error "Attempt to allocate a vector larger than ~s bytes long"
  2206.              (1- (expt 2 24))))
  2207.     (when initial-element
  2208.       (unless ie-imm?
  2209.         (error "Attempt to create a bit-vector with a non-bit initial-element."))
  2210.       (ecase initial-element
  2211.         (0)
  2212.         (1 (setq initial-element #xff))))
  2213.     (locally (declare (fixnum bytes))
  2214.       (let* ((address (%allocate-storage disk-cache area (+ $vector-header-size bytes)))
  2215.              (res (initialize-vector-storage
  2216.                    disk-cache (- address $t_cons) bytes $v_bitv 1
  2217.                    initial-element ie-imm?)))
  2218.         (setf (read-8-bits disk-cache (addr+ disk-cache res $v_data)) (mod length 8))
  2219.         res))))
  2220.  
  2221. (defun p-make-array (pheap dimensions &key 
  2222.                            area
  2223.                            (element-type t)
  2224.                            initial-contents
  2225.                            initial-element
  2226.                            adjustable
  2227.                            fill-pointer
  2228.                            displaced-to
  2229.                            displaced-index-offset)
  2230.   (let (ie ie-imm?)
  2231.     (when initial-element               ; NIL is the default
  2232.       (multiple-value-setq (ie ie-imm?) (%p-store pheap initial-element)))
  2233.     (pptr pheap
  2234.           (dc-make-array
  2235.            (pheap-disk-cache pheap)
  2236.            (p-load dimensions)
  2237.            (if (pptr-p area) 
  2238.              (pheap-pptr-pointer area pheap)
  2239.              (pheap-consing-area pheap))
  2240.            (p-load element-type)
  2241.            ie
  2242.            ie-imm?
  2243.            initial-contents
  2244.            adjustable
  2245.            fill-pointer
  2246.            displaced-to
  2247.            displaced-index-offset))))
  2248.  
  2249. (defun dc-make-array (disk-cache dimensions &optional
  2250.                                  area (element-type t) initial-element ie-imm?
  2251.                                  initial-contents adjustable
  2252.                                  fill-pointer displaced-to
  2253.                                  displaced-index-offset)
  2254.   (when (or initial-contents adjustable fill-pointer
  2255.             displaced-to displaced-index-offset)
  2256.     (error "Unsupported array option. Only support :initial-element & :area"))
  2257.   (let ((subtype (array-element-type->subtype element-type)))
  2258.     (if (or (atom dimensions) (null (cdr dimensions)))
  2259.       ; one-dimensional array
  2260.       (let ((length (require-type
  2261.                      (if (atom dimensions) dimensions (car dimensions))
  2262.                      'fixnum)))
  2263.         (dc-make-uvector disk-cache length subtype area initial-element ie-imm?))
  2264.       ; multi-dimensional array
  2265.       (progn
  2266.         (dolist (dim dimensions)
  2267.           (unless (and (fixnump dim) (>= dim 0))
  2268.             (error "Array dimension not a fixnum or less than 0: ~s")))
  2269.         (let ((rank (length dimensions))
  2270.               (length (apply #'* dimensions)))
  2271.           (unless (fixnump length)
  2272.             (error "Attempt to create multidimensional of size > ~s"
  2273.                    most-positive-fixnum))
  2274.           (unless (< rank (/ (expt 2 15) 4))
  2275.             (error "rank ~s > (/ (expt 2 15) 4)" rank))
  2276.           (let ((vector (dc-make-uvector
  2277.                          disk-cache length subtype area initial-element ie-imm?))
  2278.                 (arrayh (dc-make-uvector disk-cache (+ $arh.dims rank) $v_arrayh area 0 t)))
  2279.             (setf (dc-%svref disk-cache arrayh $arh.vect) vector
  2280.                   (dc-%arrayh-rank4 disk-cache arrayh) (* 4 rank)
  2281.                   (dc-%arrayh-type disk-cache arrayh) (wood->ccl-subtype subtype)
  2282.                   (dc-%arrayh-bits disk-cache arrayh) (ash 1 $arh_simple_bit))
  2283.             (let ((dims dimensions)
  2284.                   (index $arh.dims))
  2285.               (declare (fixnum index))
  2286.               (dotimes (i (the fixnum rank))
  2287.                 (setf (dc-%svref disk-cache arrayh index t) (pop dims))
  2288.                 (incf index)))
  2289.             arrayh))))))
  2290.             
  2291.  
  2292. (defparameter *array-element-type->subtype*
  2293.   '((bit . #.$v_bitv)
  2294.     ((signed-byte 8) . #.$v_sbytev)
  2295.     ((unsigned-byte 8) . #.$v_ubytev)
  2296.     ((signed-byte 16) . #.$v_swordv)
  2297.     ((unsigned-byte 16) . #.$v_uwordv)
  2298.     ((signed-byte 32) . #.$v_slongv)
  2299.     ((unsigned-byte 32) . #.$v_ulongv)
  2300.     (double-float . #.$v_floatv)
  2301.     (character . #.$v_sstr)
  2302.     (t . #.$v_genv)))
  2303.  
  2304. (defun array-element-type->subtype (element-type)
  2305.   (if (eq element-type t)
  2306.     $v_genv
  2307.     (dolist (pair *array-element-type->subtype*
  2308.                   (error "Can't find subtype. Shouldn't happen."))
  2309.       (if (subtypep element-type (car pair))
  2310.         (return (cdr pair))))))
  2311.  
  2312. (defun p-vector (pheap &rest elements)
  2313.   (declare (dynamic-extent elements))
  2314.   (p-uvector* pheap $v_genv elements))
  2315.  
  2316. (defun p-uvector (pheap subtype &rest elements)
  2317.   (declare (dynamic-extent elements))
  2318.   (p-uvector* pheap subtype elements))
  2319.  
  2320. (defun p-uvector* (pheap subtype elements)
  2321.   (let* ((genv? (eql (svref *subtype->uvsetter* subtype) 'uvset-genv))
  2322.          (vector (p-make-uvector pheap (length elements) subtype))
  2323.          (disk-cache (pheap-disk-cache pheap))
  2324.          (vector-pointer (pptr-pointer vector))
  2325.          (i 0))
  2326.     (if genv?
  2327.       (dolist (element elements)
  2328.         (multiple-value-bind (e imm?) (%p-store pheap element)
  2329.           (setf (dc-%svref disk-cache vector-pointer i imm?) e)
  2330.           (incf i)))
  2331.       (dolist (element elements)
  2332.         (multiple-value-bind (e imm?) (%p-store pheap element)
  2333.           (setf (dc-uvref disk-cache vector-pointer i imm?) e)
  2334.           (incf i))))
  2335.     vector))
  2336.  
  2337. (defun p-cons-population (pheap data &optional (type 0))
  2338.   (p-uvector pheap $v_weakh nil type data))
  2339.  
  2340. (def-accessor ccl::population-data (p) (disk-cache pointer)
  2341.   (require-satisfies dc-vector-subtype-p disk-cache pointer $v_weakh)
  2342.   (dc-%svref disk-cache pointer $population.data))
  2343.               
  2344.  
  2345.  
  2346. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2347. ;;;
  2348. ;;; Packages and symbols
  2349. ;;;
  2350.       
  2351. (defun p-find-package (pheap package)
  2352.   (if (and (pptr-p package)
  2353.            (p-packagep package))
  2354.     package
  2355.     (multiple-value-bind (pkg pkg-imm?) (split-pptr package)
  2356.       (let ((pointer (dc-find-package (pheap-disk-cache pheap) pkg pkg-imm?)))
  2357.         (when pointer
  2358.           (pptr pheap pointer))))))
  2359.  
  2360. ; Returns a disk-resident package, memory-resident package, or memory-resident string
  2361. (defun dc-canonicalize-pkg-arg (disk-cache pkg pkg-imm?)
  2362.   (if pkg-imm?
  2363.     (values
  2364.      (if (packagep pkg)
  2365.        pkg
  2366.        (string pkg))
  2367.      t)
  2368.     (if (dc-packagep disk-cache pkg)
  2369.       pkg
  2370.       (values (pointer-load (disk-cache-pheap disk-cache)
  2371.                             (dc-string disk-cache pkg)
  2372.                             :default
  2373.                             disk-cache)
  2374.               t))))
  2375.  
  2376. (defun dc-find-package (disk-cache pkg &optional pkg-imm?)
  2377.   (multiple-value-bind (pkg pkg-imm?) (dc-canonicalize-pkg-arg disk-cache pkg pkg-imm?)
  2378.     (if (not pkg-imm?)
  2379.       pkg
  2380.       (let* ((pkg-name (if (packagep pkg)
  2381.                          (package-name pkg)
  2382.                          (string pkg)))
  2383.              (btree (dc-package-btree disk-cache nil)))
  2384.         (and btree
  2385.              (dc-btree-lookup disk-cache btree pkg-name))))))
  2386.  
  2387. (defun p-package-btree (pheap &optional (create? t))
  2388.   (let ((pointer (dc-package-btree (pheap-disk-cache pheap) create?)))
  2389.     (and pointer (pptr pheap pointer))))
  2390.  
  2391. (defun dc-package-btree (disk-cache &optional (create? t))
  2392.   (let ((btree (dc-%svref disk-cache $root-vector $pheap.package-btree)))
  2393.     (if (not (eql $pheap-nil btree))
  2394.       btree
  2395.       (when create?
  2396.         (setf (dc-%svref disk-cache $root-vector $pheap.package-btree)
  2397.               (dc-make-btree disk-cache))))))
  2398.  
  2399. (defun p-make-package (pheap package-name &key nicknames)
  2400.   (pptr pheap (dc-make-package (pheap-disk-cache pheap)
  2401.                                (p-load package-name)
  2402.                                (p-load nicknames))))
  2403.  
  2404. (defun dc-make-package (disk-cache name &optional nicknames)
  2405.   (let* ((pkg-name (ensure-simple-string (string name)))
  2406.          (btree (dc-package-btree disk-cache)))
  2407.     (if (dc-btree-lookup disk-cache btree pkg-name)
  2408.       (error "package name ~s already in use in ~s"
  2409.              pkg-name (disk-cache-pheap disk-cache))
  2410.       (dc-btree-store
  2411.        disk-cache
  2412.        btree
  2413.        pkg-name
  2414.        (dc-cons-package disk-cache pkg-name nicknames)))))
  2415.  
  2416. (defun p-cons-package (pheap pkg-name &optional nicknames)
  2417.   (pptr pheap
  2418.         (dc-cons-package (pheap-disk-cache pheap)
  2419.                          (p-load pkg-name)
  2420.                          (p-load nicknames)
  2421.                          pheap)))
  2422.  
  2423. (defun dc-cons-package (disk-cache pkg-name &optional
  2424.                                    nicknames
  2425.                                    (pheap (disk-cache-pheap disk-cache)))
  2426.   (let* ((names (mapcar #'(lambda (x) (ensure-simple-string (string x)))
  2427.                         (cons pkg-name nicknames)))
  2428.          (p-names (%p-store pheap names))
  2429.          (package (dc-make-uvector disk-cache $pkg-length $v_pkg)))
  2430.     (setf (dc-uvref disk-cache package $pkg.names) p-names
  2431.           (dc-uvref disk-cache package $pkg.btree) (dc-make-btree disk-cache))
  2432.     package))
  2433.         
  2434.  
  2435. (defun p-intern (pheap string &key
  2436.                        (package *package*)
  2437.                        (area nil area-p))
  2438.   (multiple-value-bind (pkg pkg-imm?) (split-pptr package)
  2439.     (pptr pheap (dc-intern (pheap-disk-cache pheap)
  2440.                            (p-load string)
  2441.                            pkg pkg-imm?
  2442.                            (if area-p 
  2443.                              (pheap-pptr-pointer area pheap)
  2444.                              (pheap-consing-area pheap))
  2445.                            pheap))))
  2446.  
  2447. (defun dc-intern (disk-cache string pkg &optional pkg-imm? area pheap)
  2448.   (let* ((pkg (dc-find-or-make-package disk-cache pkg pkg-imm?))
  2449.          (str (require-type string 'string))
  2450.          (btree (dc-%svref disk-cache pkg $pkg.btree)))
  2451.     (or (dc-btree-lookup disk-cache btree str)
  2452.         (dc-btree-store
  2453.          disk-cache
  2454.          btree
  2455.          (setq str (ensure-simple-string str))
  2456.          (dc-cons-symbol disk-cache
  2457.                          (%p-store (or pheap (disk-cache-pheap disk-cache)) str)
  2458.                          pkg area)))))
  2459.  
  2460. (defun dc-find-or-make-package (disk-cache package &optional pkg-imm?)
  2461.   (multiple-value-bind (pkg pkg-imm?)
  2462.                        (dc-canonicalize-pkg-arg disk-cache package pkg-imm?)
  2463.     (or (dc-find-package disk-cache pkg pkg-imm?)
  2464.         (let* ((pkg (or (if (packagep package) package (find-package package))
  2465.                         (error "There is no package named ~s package")))
  2466.                (pkg-name (package-name pkg))
  2467.                (nicknames (package-nicknames pkg)))
  2468.           (dc-make-package disk-cache pkg-name nicknames)))))
  2469.  
  2470. (defun dc-cons-symbol (disk-cache string-pointer package &optional area)
  2471.   (let ((sym (+ (- $t_symbol $t_cons)
  2472.                 (%allocate-storage disk-cache area $symbol-size))))
  2473.     (setf (read-long disk-cache (+ sym $sym_header)) $symbol-header
  2474.           (read-long disk-cache (+ sym $sym_pname)) string-pointer
  2475.           (read-long disk-cache (+ sym $sym_package)) package
  2476.           (read-long disk-cache (+ sym $sym_values)) $pheap-nil)
  2477.     sym))
  2478.  
  2479. (defun p-find-symbol (pheap string &optional (package *package*))
  2480.   (multiple-value-bind (pkg pkg-imm?) (split-pptr package)
  2481.     (let ((pointer (dc-find-symbol (pheap-disk-cache pheap) string pkg pkg-imm?)))
  2482.       (and pointer (pptr pheap pointer)))))
  2483.  
  2484. (defun dc-find-symbol (disk-cache string &optional (package *package*) pkg-imm?)
  2485.   (let* ((pkg (dc-find-package disk-cache package pkg-imm?))
  2486.          (str (require-type string 'string)))
  2487.     (and pkg
  2488.          (dc-btree-lookup disk-cache
  2489.                           (dc-%svref disk-cache pkg $pkg.btree)
  2490.                           str))))
  2491.  
  2492. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2493. ;;;
  2494. ;;; Hash tables
  2495. ;;;
  2496.  
  2497. (defun p-make-hash-table (pheap &key (test 'eq) weak area)
  2498.   (pptr pheap (dc-make-hash-table 
  2499.                (pheap-disk-cache pheap)
  2500.                :test test
  2501.                :weak weak
  2502.                :area (maybe-default-area pheap area))))
  2503.  
  2504. (defun dc-make-hash-table (disk-cache &key (test 'eq) weak area)
  2505.   (unless (or (eq test 'eq) (eq test #'eq))
  2506.     (error "Only ~s hash tables supported" 'eq))
  2507.   (let ((type (ecase weak
  2508.                 ((nil) $btree-type_eqhash)
  2509.                 (:key $btree-type_eqhash-weak-key)
  2510.                 (:value $btree-type_eqhash-weak-value))))
  2511.     (dc-make-btree disk-cache area type)))
  2512.  
  2513. (defun p-btree-p (p)
  2514.   (and (pptr-p p)
  2515.        (dc-btree-p (pptr-disk-cache p) (pptr-pointer p))))
  2516.  
  2517. (defun dc-btree-p (disk-cache pointer)
  2518.   (dc-vector-subtype-p disk-cache pointer $v_btree))
  2519.  
  2520. (def-predicate hash-table-p (p disk-cache pointer)
  2521.   (and (dc-btree-p disk-cache pointer)
  2522.        (> (dc-uvsize disk-cache pointer) $btree.type)   ; early versions missing this slot
  2523.        (logbitp $btree-type_eqhash-bit
  2524.                 (dc-%svref-fixnum disk-cache pointer $btree.type '$btree.type))))
  2525.  
  2526. (def-accessor hash-table-count (p) (disk-cache pointer)
  2527.   (require-satisfies dc-hash-table-p disk-cache pointer)
  2528.   (dc-btree-count disk-cache pointer))
  2529.  
  2530. (def-accessor btree-count (p) (disk-cache pointer)
  2531.   (require-satisfies dc-btree-p disk-cache pointer)
  2532.   (dc-%svref disk-cache pointer $btree.count))
  2533.  
  2534. (defun btree-count (p)
  2535.   (declare (ignore p))
  2536.   (error "~s is only defined for wood btrees" 'btree-count))
  2537.  
  2538. (defun wood-immediate-p (object)
  2539.   (svref #(t                            ; $t_fixnum
  2540.            nil                          ; $t_vector
  2541.            nil                          ; $t_symbol
  2542.            nil                          ; $t_dfloat
  2543.            nil                          ; $t_cons
  2544.            t                            ; $t_sfloat
  2545.            nil                          ; $t_lfun
  2546.            t)                           ; $t_imm
  2547.          (ccl::%ttag object)))
  2548.  
  2549. (defun p-gethash (key hash &optional default)
  2550.   (if (pptr-p hash)
  2551.     (let* ((pheap (pptr-pheap hash))
  2552.            (hash-pointer (pptr-pointer hash))
  2553.            (disk-cache (pheap-disk-cache pheap)))
  2554.       (require-satisfies dc-hash-table-p disk-cache hash-pointer)
  2555.       (multiple-value-bind (value imm?) (%p-store-hash-key pheap key)
  2556.         (multiple-value-bind (res res-imm? found?)
  2557.                              (and value
  2558.                                   (dc-gethash disk-cache value imm? hash-pointer))
  2559.           (if found?
  2560.             (values
  2561.              (if res-imm?
  2562.                res
  2563.                (pptr pheap res))
  2564.              t)
  2565.             default))))
  2566.     (gethash key hash default)))
  2567.  
  2568. ; This could be just %p-store, but I'd rather not look in the
  2569. ; btree if I know that the key can't be EQ.
  2570. (defun %p-store-hash-key (pheap key)
  2571.   (if (pptr-p key)
  2572.     (pheap-pptr-pointer key pheap)
  2573.     (cond ((wood-immediate-p key) (values key t))
  2574.           ((null key) $pheap-nil)
  2575.           (t
  2576.            (maybe-cached-address pheap key
  2577.              ; This will be slightly faster if the p-find-xxx's are changed
  2578.              ; to dc-find-xxx.
  2579.              (or (cond ((symbolp key)
  2580.                         (split-pptr (p-find-symbol
  2581.                                      pheap (symbol-name key) (symbol-package key))))
  2582.                        ((packagep key)
  2583.                         (split-pptr (p-find-package pheap key)))
  2584.                        ((typep key 'class)
  2585.                         (split-pptr (p-find-class pheap key nil))))
  2586.                  (return-from %p-store-hash-key nil)))))))
  2587.  
  2588.  
  2589. (defmacro with-dc-hash-key ((key-var key key-imm?) &body body)
  2590.   (let ((s4 (gensym))
  2591.         (s3 (gensym))
  2592.         (s2 (gensym))
  2593.         (s1 (gensym)))
  2594.     `(let* ((,s4 (make-string 4))
  2595.             (,s3 (make-string 3))
  2596.             (,s2 (make-string 2))
  2597.             (,s1 (make-string 1))
  2598.             ,key-var)
  2599.        (declare (dynamic-extent ,s4 ,s3 ,s2 ,s1))
  2600.        (%store-pointer ,key ,s4 0 ,key-imm?)
  2601.        (locally (declare (optimize (speed 3) (safety 0)))
  2602.          (if (eql #\000 (schar ,s4 0))
  2603.            (if (eql #\000 (schar ,s4 1))
  2604.              (if (eql #\000 (schar ,s4 2))
  2605.                (setf (schar ,s1 0) (schar ,s4 3)
  2606.                      ,key-var ,s1)
  2607.                (setf (schar ,s2 0) (schar ,s4 2)
  2608.                      (schar ,s2 1) (schar ,s4 3)
  2609.                      ,key-var ,s2))
  2610.              (setf (schar ,s3 0) (schar ,s4 1)
  2611.                    (schar ,s3 1) (schar ,s4 2)
  2612.                    (schar ,s3 2) (schar ,s4 3)
  2613.                    ,key-var ,s3))
  2614.            (setq ,key-var ,s4)))
  2615.        ,@body)))
  2616.  
  2617. (defun dc-hash-key-value (key-string)
  2618.   (let* ((s (make-string 4))
  2619.          (len (length key-string)))
  2620.     (declare (dynamic-extent s)
  2621.              (fixnum len))
  2622.     (locally (declare (optimize (speed 3) (safety 0)))
  2623.       (setf (schar s 0)
  2624.             (setf (schar s 1)
  2625.                   (setf (schar s 2)
  2626.                         (setf (schar s 3) #\000)))))
  2627.     (if (> len 4) (error "Bad hash-table key-string: ~s" key-string))
  2628.     (%copy-byte-array-portion key-string 0 len s (the fixnum (- 4 len)))
  2629.     (%load-pointer s 0)))
  2630.  
  2631. (defun dc-gethash (disk-cache key key-imm? hash)
  2632.   (with-dc-hash-key (key-string key key-imm?)
  2633.     (dc-btree-lookup disk-cache hash key-string)))
  2634.   
  2635. (defun (setf p-gethash) (value key hash &optional default)
  2636.   (declare (ignore default))
  2637.   (if (pptr-p hash)
  2638.     (let* ((pheap (pptr-pheap hash))
  2639.            (hash-pointer (pptr-pointer hash))
  2640.            (disk-cache (pheap-disk-cache pheap)))
  2641.       (require-satisfies dc-hash-table-p disk-cache hash-pointer)
  2642.       (multiple-value-bind (vp vi?) (%p-store pheap value)
  2643.         (multiple-value-bind (kp ki?) (%p-store pheap key)
  2644.           (dc-puthash disk-cache kp ki? hash-pointer vp vi?)
  2645.           (if vi?
  2646.             vp
  2647.             (pptr pheap vp)))))
  2648.     (setf (gethash key hash) value)))
  2649.  
  2650. (defun dc-puthash (disk-cache key key-imm? hash value &optional value-imm?)
  2651.   (with-dc-hash-key (key-string key key-imm?)
  2652.     (dc-btree-store disk-cache hash key-string value value-imm?)))
  2653.  
  2654. (defun p-remhash (key hash)
  2655.   (if (pptr-p hash)
  2656.     (let ((pheap (pptr-pheap hash)))
  2657.       (multiple-value-bind (value imm?) (%p-store-hash-key pheap key)
  2658.         (dc-remhash (pheap-disk-cache pheap) value imm? (pptr-pointer hash))))
  2659.     (remhash key hash)))
  2660.  
  2661. (defun dc-remhash (disk-cache key key-imm? hash)
  2662.   (with-dc-hash-key (key-string key key-imm?)
  2663.     (dc-btree-delete disk-cache hash key-string)))
  2664.  
  2665. (defun p-clrhash (hash)
  2666.   (if (pptr-p hash)
  2667.     (progn
  2668.       (dc-clrhash (pptr-disk-cache hash) (pptr-pointer hash))
  2669.       hash)
  2670.     (clrhash hash)))
  2671.  
  2672. (defun dc-clrhash (disk-cache hash)
  2673.   (dc-clear-btree disk-cache hash))
  2674.  
  2675. (defun p-maphash (function hash)
  2676.   (if (pptr-p hash)
  2677.     (let* ((pheap (pptr-pheap hash))
  2678.            (f #'(lambda (disk-cache key value value-imm?)
  2679.                   (declare (ignore disk-cache))
  2680.                   (multiple-value-bind (key-value key-imm?) (dc-hash-key-value key)
  2681.                     (funcall function
  2682.                              (if key-imm? key-value (pptr pheap key-value))
  2683.                              (if value-imm? value (pptr pheap value)))))))
  2684.       (declare (dynamic-extent f))
  2685.       (dc-map-btree (pheap-disk-cache pheap) (pptr-pointer hash) f))
  2686.     (maphash function hash)))
  2687.  
  2688. #|
  2689.  
  2690. ; Remove a pptr from the caches.
  2691. ; Used while debugging p-xxx accessors
  2692. (defun pptr-decache (pptr)
  2693.   (let* ((pheap (pptr-pheap pptr))
  2694.          (pointer (pptr-pointer pptr))
  2695.          (pheap->mem-hash (pheap->mem-hash pheap)))
  2696.     (multiple-value-bind (value found) (gethash pointer pheap->mem-hash)
  2697.       (when found
  2698.         (remhash pointer pheap->mem-hash)
  2699.         (remhash value (mem->pheap-hash pheap))))))
  2700.     
  2701.  
  2702. (defun init-temp-pheap ()
  2703.   (declare (special pheap dc))
  2704.   (when (boundp 'pheap)
  2705.     (close-pheap pheap))
  2706.   (delete-file "temp.pheap")
  2707.   (create-pheap "temp.pheap")
  2708.   (setq pheap (open-pheap "temp.pheap")
  2709.         dc (pheap-disk-cache pheap))
  2710.   (dolist (w (windows :class 'inspector::inspector-window))
  2711.     (window-close w))
  2712.   (inspect dc))
  2713.  
  2714. (setq p $pheap-nil)
  2715.  
  2716. (time
  2717.  (dotimes (i 200)
  2718.    (setq p (dc-cons dc i p t nil))))
  2719.  
  2720. (time
  2721.    (dotimes (i 1000)
  2722.      (setq p (dc-make-uvector dc 12 $v_genv nil p))))
  2723.  
  2724. (defun crash-close (pheap)
  2725.   (let ((disk-cache (pheap-disk-cache pheap)))
  2726.     (close (disk-cache-stream disk-cache))
  2727.     (setq *open-disk-caches* (delq disk-cache *open-disk-caches*)
  2728.           *open-pheaps* (delq pheap *open-pheaps*)))
  2729.   nil)
  2730.  
  2731. |#